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