1#lang racket/base 2(require racket/cmdline 3 racket/file 4 compiler/private/mach-o 5 compiler/private/pe-rsrc 6 compiler/private/elf 7 "adjust-compress.rkt") 8 9(define alt-dests '()) 10(define rewrites '()) 11(define target #f) 12 13(command-line 14 #:once-each 15 [("--compress") "Leave compiled code files as compressed" 16 (enable-compress!)] 17 [("--target") machine "Select target machine" 18 (set! target machine)] 19 #:multi 20 [("++exe") src dest "Select an alternative executable" 21 (set! alt-dests (cons (cons src dest) alt-dests))] 22 [("++rewrite") from to "Add an arbitrary string replacement" 23 (set! rewrites (cons (cons from to) rewrites))] 24 #:args (src-file dest-file petite.boot scheme.boot racket.boot) 25 26 ;; If `src-file` is "", then `dest-file` is used as the src, too 27 28 (define bstr1 (adjust-compress (file->bytes petite.boot))) 29 (define bstr2 (adjust-compress (file->bytes scheme.boot))) 30 (define bstr3 (adjust-compress (file->bytes racket.boot))) 31 32 (define use-src-file 33 (if (equal? src-file "") 34 (let ([src-file (path-add-suffix dest-file #"_tmp")]) 35 (rename-file-or-directory dest-file src-file) 36 src-file) 37 src-file)) 38 (define (clean-src) 39 (unless (eq? use-src-file src-file) 40 (delete-file use-src-file))) 41 42 (with-handlers ([exn? (lambda (x) 43 (clean-src) 44 (when (file-exists? dest-file) 45 (delete-file dest-file)) 46 (raise x))]) 47 (define terminator 48 ;; A 127 byte teriminates a fasl-read sequence 49 #"\177") 50 (define data 51 (bytes-append bstr1 terminator 52 bstr2 terminator 53 bstr3 terminator)) 54 (define pos 55 (case (or target (path->string (system-library-subpath #f))) 56 [("ta6osx" "ti3osx" "tarm64osx" 57 "x86_64-darwin" "i386-darwin" "aarch64-darwin" 58 "x86_64-macosx" "i386-macosx" "aarch64-macosx") 59 ;; Mach-O 60 (when (file-exists? dest-file) 61 ;; explicit delete to avoid signature unhappiness 62 (delete-file dest-file)) 63 (copy-file use-src-file dest-file) 64 (remove-signature dest-file) 65 (add-plt-segment dest-file data #:name #"__RKTBOOT") 66 ;; Find segment at run time: 67 0] 68 [("ta6nt" "ti3nt" "win32\\x86_64" "win32\\i386") 69 (copy-file use-src-file dest-file #t) 70 (define-values (pe rsrcs) (call-with-input-file* 71 dest-file 72 read-pe+resources)) 73 (define new-rsrcs (resource-set rsrcs 74 ;; Racket's "user-defined" type for boot: 75 259 76 1 77 1033 ; U.S. English 78 data)) 79 (update-resources dest-file pe new-rsrcs) 80 ;; Find resource at run time: 81 0] 82 [else 83 ;; ELF? 84 (define-values (start-pos end-pos any1 any2) 85 (add-racket-section use-src-file dest-file #".rackboot" 86 (lambda (pos) 87 (values data 'any1 'any2)))) 88 (cond 89 [start-pos 90 ;; Success as ELF 91 (file-or-directory-permissions dest-file (file-or-directory-permissions use-src-file 'bits)) 92 ;; Find ".rackboot" at run time: 93 0] 94 [else 95 ;; Not ELF; just append to the end 96 (copy-file use-src-file dest-file #t) 97 (define pos (file-size dest-file)) 98 (call-with-output-file* 99 dest-file 100 #:exists 'update 101 (lambda (o) 102 (file-position o pos) 103 (write-bytes data o))) 104 pos])])) 105 106 (for ([rewrite (in-list rewrites)]) 107 (define from (car rewrite)) 108 (define to (cdr rewrite)) 109 (let loop () 110 (define i (open-input-file dest-file)) 111 (define m (regexp-match-positions from i)) 112 (close-input-port i) 113 (when m 114 (define o (open-output-file dest-file #:exists 'update)) 115 (file-position o (caar m)) 116 (display to o) 117 (close-output-port o) 118 (loop)))) 119 120 (define (write-offsets dest-file) 121 (define-values (i o) (open-input-output-file dest-file #:exists 'update)) 122 (define m (regexp-match-positions #rx"BooT FilE OffsetS:" i)) 123 (unless m 124 (error 'embed-boot "cannot file boot-file offset tag")) 125 126 (define terminator-len (bytes-length terminator)) 127 128 (define big-endian? 129 (if target 130 (case target 131 [("tppc32le") #t] 132 [else #f]) 133 (system-big-endian?))) 134 135 (file-position o (cdar m)) 136 (void (write-bytes (integer->integer-bytes pos 4 #t big-endian?) o)) 137 (let ([pos (+ pos (bytes-length bstr1) terminator-len)]) 138 (void (write-bytes (integer->integer-bytes pos 4 #t big-endian?) o)) 139 (let ([pos (+ pos (bytes-length bstr2) terminator-len)]) 140 (void (write-bytes (integer->integer-bytes pos 4 #t big-endian?) o)) 141 (let ([pos (+ pos (bytes-length bstr3) terminator-len)]) 142 (void (write-bytes (integer->integer-bytes pos 4 #t big-endian?) o)))))) 143 144 (cond 145 [(null? alt-dests) 146 (write-offsets dest-file)] 147 [else 148 (for ([alt (in-list alt-dests)]) 149 (copy-file (car alt) (cdr alt) #t) 150 (write-offsets (cdr alt)))]) 151 152 (clean-src))) 153