directly manipulate mach-o to change framework path or to add code for a stand-alone executable
svn: r2937
This commit is contained in:
Matthew Flatt
parent
8b0873adf4
commit
9be16da09b
|
|
@ -13,6 +13,7 @@
|
|||
"private/winicon.ss"
|
||||
"private/winsubsys.ss"
|
||||
"private/macfw.ss"
|
||||
"private/mach-o.ss"
|
||||
"private/windlldir.ss")
|
||||
|
||||
(provide compiler:embed@)
|
||||
|
|
@ -607,12 +608,23 @@
|
|||
(let-values ([(orig-dir name dir?) (split-path
|
||||
(path->complete-path orig-exe))])
|
||||
(update-dll-dir dest (build-path orig-dir dir))))))))
|
||||
(let ([start (file-size dest-exe)])
|
||||
(with-output-to-file dest-exe
|
||||
(lambda ()
|
||||
(write-module-bundle verbose? modules literal-files literal-expression))
|
||||
'append)
|
||||
(let ([end (file-size dest-exe)])
|
||||
(let ([write-module
|
||||
(lambda ()
|
||||
(write-module-bundle verbose? modules literal-files literal-expression))])
|
||||
(let-values ([(start end)
|
||||
(if (eq? (system-type) 'macosx)
|
||||
;; For Mach-O, we know how to add a proper segment
|
||||
(let ([s (open-output-bytes)])
|
||||
(parameterize ([current-output-port s])
|
||||
(write-module))
|
||||
(let ([s (get-output-bytes s)])
|
||||
(let ([start (add-plt-segment dest-exe s)])
|
||||
(values start
|
||||
(+ start (bytes-length s))))))
|
||||
;; Other platforms: just add to the end of the file:
|
||||
(let ([start (file-size dest-exe)])
|
||||
(with-output-to-file dest-exe write-module 'append)
|
||||
(values start (file-size dest-exe))))])
|
||||
(when verbose?
|
||||
(fprintf (current-error-port) "Setting command line~n"))
|
||||
(let ([start-s (number->string start)]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
|
||||
(module macfw mzscheme
|
||||
(require (lib "process.ss"))
|
||||
(require "mach-o.ss"
|
||||
(lib "string.ss")
|
||||
(lib "process.ss"))
|
||||
|
||||
(provide update-framework-path
|
||||
get-current-framework-path
|
||||
|
|
@ -20,43 +22,36 @@
|
|||
(let* ([orig (get-current-framework-path dest p)]
|
||||
[3m (if (and orig (regexp-match #rx"_3m" orig))
|
||||
"_3m"
|
||||
"")])
|
||||
(system* "/usr/bin/install_name_tool"
|
||||
"-change"
|
||||
(or orig
|
||||
(format "~a.framework/Versions/~a~a/~a" p (version) 3m p))
|
||||
(format "~a~a.framework/Versions/~a~a/~a"
|
||||
fw-path
|
||||
p (version) 3m p)
|
||||
dest)))
|
||||
"")]
|
||||
[old-path (or orig
|
||||
(format "~a.framework/Versions/~a~a/~a" p (version) 3m p))]
|
||||
[new-path (format "~a~a.framework/Versions/~a~a/~a"
|
||||
fw-path
|
||||
p (version) 3m p)])
|
||||
(get/set-dylib-path dest
|
||||
(byte-regexp
|
||||
(bytes-append
|
||||
#"^"
|
||||
(string->bytes/utf-8
|
||||
(regexp-quote old-path))
|
||||
#"$"))
|
||||
(string->bytes/utf-8 new-path))))
|
||||
(if mred?
|
||||
'("PLT_MrEd")
|
||||
'("PLT_MzScheme")))))
|
||||
|
||||
(define (get-current-framework-path dest p)
|
||||
(let-values ([(r w) (make-pipe)])
|
||||
(parameterize ([current-output-port w])
|
||||
(system* "/usr/bin/otool"
|
||||
"-L"
|
||||
(if (path? dest)
|
||||
(path->string dest)
|
||||
dest)))
|
||||
(close-output-port w)
|
||||
(let ([m (regexp-match (bytes-append #"[\r\n][ \t]*([^ \t][^\r\n]*"
|
||||
(string->bytes/utf-8 p)
|
||||
#"[^\r\n]*)"
|
||||
#" [(]compatibility version [0-9.]*,"
|
||||
#" current version [0-9.]*[)][\r\n]")
|
||||
r)])
|
||||
(if m
|
||||
(bytes->string/utf-8 (cadr m))
|
||||
(begin
|
||||
(fprintf (current-error-port)
|
||||
"warning: cannot find existing link for ~a in ~a\n"
|
||||
p dest)
|
||||
#f))))))
|
||||
(let ([v (get/set-dylib-path dest
|
||||
(byte-regexp (string->bytes/utf-8 p))
|
||||
#f)])
|
||||
(if v
|
||||
(bytes->string/utf-8 v)
|
||||
(begin
|
||||
(fprintf (current-error-port)
|
||||
"warning: cannot find existing link for ~a in ~a\n"
|
||||
p dest)
|
||||
#f)))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,13 +1,14 @@
|
|||
(module mach-o mzscheme
|
||||
|
||||
(provide add-plt-segment)
|
||||
(provide add-plt-segment
|
||||
get/set-dylib-path)
|
||||
|
||||
(define (read-ulong p)
|
||||
(integer-bytes->integer (read-bytes 4 p) #f #t))
|
||||
(integer-bytes->integer (read-bytes 4 p) #f))
|
||||
|
||||
(define (write-ulong v out)
|
||||
(display (integer->integer-bytes v 4 #f #t) out))
|
||||
|
||||
(display (integer->integer-bytes v 4 #f) out))
|
||||
|
||||
(define (check-same a b)
|
||||
(unless (= a b)
|
||||
(error 'check-same "not: ~e ~e" a b)))
|
||||
|
|
@ -15,6 +16,12 @@
|
|||
(define (round-up-page v)
|
||||
(bitwise-and #xFFFFF000 (+ v #xFFF)))
|
||||
|
||||
(define (mult-of-4 n)
|
||||
(let ([m (modulo n 4)])
|
||||
(if (zero? m)
|
||||
n
|
||||
(+ n (- 4 m)))))
|
||||
|
||||
(define move-link-edit? #t)
|
||||
|
||||
(define (add-plt-segment file segdata)
|
||||
|
|
@ -37,14 +44,14 @@
|
|||
[link-edit-addr 0]
|
||||
[link-edit-offset 0]
|
||||
[link-edit-len 0])
|
||||
(printf "~a cmds, length 0x~x\n" cnt cmdssz)
|
||||
;; (printf "~a cmds, length 0x~x\n" cnt cmdssz)
|
||||
(read-ulong p)
|
||||
(let loop ([cnt cnt])
|
||||
(unless (zero? cnt)
|
||||
(let ([pos (file-position p)]
|
||||
[cmd (read-ulong p)]
|
||||
[sz (read-ulong p)])
|
||||
(printf "~x (~a)\n" cmd sz)
|
||||
;; (printf "~x (~a)\n" cmd sz)
|
||||
(case cmd
|
||||
[(1)
|
||||
;; Segment
|
||||
|
|
@ -53,13 +60,13 @@
|
|||
[vmlen (read-ulong p)]
|
||||
[offset (read-ulong p)]
|
||||
[len (read-ulong p)])
|
||||
(printf "~s\n" segname)
|
||||
;; (printf "~s\n" segname)
|
||||
(when (equal? segname #"__LINKEDIT\0\0\0\0\0\0")
|
||||
(set! link-edit-pos pos)
|
||||
(set! link-edit-addr vmaddr)
|
||||
(set! link-edit-offset offset)
|
||||
(set! link-edit-len len))
|
||||
(printf " 0x~x 0x~x -> 0x~x 0x~x\n" offset len vmaddr vmlen)
|
||||
;; (printf " 0x~x 0x~x -> 0x~x 0x~x\n" offset len vmaddr vmlen)
|
||||
(read-ulong p)
|
||||
(read-ulong p)
|
||||
(let ([nsects (read-ulong p)])
|
||||
|
|
@ -73,10 +80,9 @@
|
|||
[offset (read-ulong p)])
|
||||
(when ((+ offset vmsz) . > . (+ cmdssz 28))
|
||||
(when (offset . < . min-used)
|
||||
(printf " new min!\n")
|
||||
;; (printf " new min!\n")
|
||||
(set! min-used offset)))
|
||||
(printf " ~s,~s 0x~x 0x~x\n"
|
||||
seg sect offset vmsz)
|
||||
;; (printf " ~s,~s 0x~x 0x~x\n" seg sect offset vmsz)
|
||||
(read-ulong p) (read-ulong p) (read-ulong p) (read-ulong p) (read-ulong p) (read-ulong p))
|
||||
(loop (sub1 nsects))))))]
|
||||
[(2)
|
||||
|
|
@ -92,7 +98,7 @@
|
|||
(void)])
|
||||
(file-position p (+ pos sz))
|
||||
(loop (sub1 cnt)))))
|
||||
(printf "Start offset: 0x~x\n" min-used)
|
||||
;; (printf "Start offset: 0x~x\n" min-used)
|
||||
(let ([end-cmd (+ cmdssz 28)]
|
||||
[new-cmd-sz 56]
|
||||
[outlen (round-up-page (bytes-length segdata))]
|
||||
|
|
@ -133,7 +139,7 @@
|
|||
(set! hints-pos (+ hints-pos 56)))
|
||||
(set! link-edit-pos (+ link-edit-pos 56))
|
||||
(file-position out (+ link-edit-pos 32))
|
||||
(printf "Update to ~a\n" (+ out-offset outlen))
|
||||
;; (printf "Update to ~a\n" (+ out-offset outlen))
|
||||
(write-ulong (+ out-offset outlen) out)
|
||||
;; Read link-edit segment:
|
||||
(file-position p link-edit-offset)
|
||||
|
|
@ -170,9 +176,20 @@
|
|||
(close-input-port p)
|
||||
(close-output-port out)))))
|
||||
|
||||
#;
|
||||
(define (get/set-dylib-path rx new-path)
|
||||
(let-values ([(p out) (open-input-output-file file 'update)])
|
||||
(define (fix-offset p pos out d base delta)
|
||||
(when (and out (not (zero? delta)))
|
||||
(file-position p (+ pos d))
|
||||
(let ([offset (read-ulong p)])
|
||||
(when (offset . > . base)
|
||||
(file-position out (+ pos d))
|
||||
(write-ulong (+ offset delta) out)
|
||||
(flush-output out)))))
|
||||
|
||||
(define (get/set-dylib-path file rx new-path)
|
||||
(let-values ([(p out) (if new-path
|
||||
(open-input-output-file file 'update)
|
||||
(values (open-input-file file)
|
||||
#f))])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
|
|
@ -181,144 +198,63 @@
|
|||
(read-ulong p)
|
||||
(check-same #x2 (read-ulong p))
|
||||
(let* ([cnt (read-ulong p)]
|
||||
[cmdssz (read-ulong p)]
|
||||
[min-used (round-up-page cmdssz)]
|
||||
[sym-tab-pos 0]
|
||||
[dysym-pos 0]
|
||||
[hints-pos 0]
|
||||
[link-edit-pos 0]
|
||||
[link-edit-addr 0]
|
||||
[link-edit-offset 0]
|
||||
[link-edit-len 0])
|
||||
(printf "~a cmds, length 0x~x\n" cnt cmdssz)
|
||||
[cmdssz (read-ulong p)])
|
||||
(read-ulong p)
|
||||
(let loop ([cnt cnt])
|
||||
(unless (zero? cnt)
|
||||
(let ([pos (file-position p)]
|
||||
[cmd (read-ulong p)]
|
||||
[sz (read-ulong p)])
|
||||
(printf "~x (~a)\n" cmd sz)
|
||||
(case cmd
|
||||
[(1)
|
||||
;; Segment
|
||||
(let ([segname (read-bytes 16 p)]
|
||||
[vmaddr (read-ulong p)]
|
||||
[vmlen (read-ulong p)]
|
||||
[offset (read-ulong p)]
|
||||
[len (read-ulong p)])
|
||||
(printf "~s\n" segname)
|
||||
(when (equal? segname #"__LINKEDIT\0\0\0\0\0\0")
|
||||
(set! link-edit-pos pos)
|
||||
(set! link-edit-addr vmaddr)
|
||||
(set! link-edit-offset offset)
|
||||
(set! link-edit-len len))
|
||||
(printf " 0x~x 0x~x -> 0x~x 0x~x\n" offset len vmaddr vmlen)
|
||||
(read-ulong p)
|
||||
(read-ulong p)
|
||||
(let ([nsects (read-ulong p)])
|
||||
(read-ulong p)
|
||||
(let loop ([nsects nsects])
|
||||
(unless (zero? nsects)
|
||||
(let ([sect (read-bytes 16 p)]
|
||||
[seg (read-bytes 16 p)]
|
||||
[vmaddr (read-ulong p)]
|
||||
[vmsz (read-ulong p)]
|
||||
[offset (read-ulong p)])
|
||||
(when ((+ offset vmsz) . > . (+ cmdssz 28))
|
||||
(when (offset . < . min-used)
|
||||
(printf " new min!\n")
|
||||
(set! min-used offset)))
|
||||
(printf " ~s,~s 0x~x 0x~x\n"
|
||||
seg sect offset vmsz)
|
||||
(read-ulong p) (read-ulong p) (read-ulong p) (read-ulong p) (read-ulong p) (read-ulong p))
|
||||
(loop (sub1 nsects))))))]
|
||||
[(2)
|
||||
;; Symbol table
|
||||
(set! sym-tab-pos pos)]
|
||||
[(#xB)
|
||||
;; Dysym
|
||||
(set! dysym-pos pos)]
|
||||
[(#x16)
|
||||
;; 2-level hints table
|
||||
(set! hints-pos pos)]
|
||||
[else
|
||||
(void)])
|
||||
(file-position p (+ pos sz))
|
||||
(loop (sub1 cnt)))))
|
||||
(printf "Start offset: 0x~x\n" min-used)
|
||||
(let ([end-cmd (+ cmdssz 28)]
|
||||
[new-cmd-sz 56]
|
||||
[outlen (round-up-page (bytes-length segdata))]
|
||||
[out-offset (if move-link-edit?
|
||||
link-edit-offset
|
||||
(+ link-edit-offset (round-up-page link-edit-len)))]
|
||||
[out-addr (+ link-edit-addr (round-up-page link-edit-len))])
|
||||
(unless ((+ end-cmd new-cmd-sz) . < . min-used)
|
||||
(error 'check-header "no room for a new section load command"))
|
||||
;; Shift commands after link-edit segment:
|
||||
(file-position p link-edit-pos)
|
||||
(let ([s (read-bytes (- end-cmd link-edit-pos) p)])
|
||||
(file-position out (+ link-edit-pos 56))
|
||||
(display s out))
|
||||
(file-position out 16)
|
||||
;; The segment:
|
||||
(write-ulong (+ cnt 1) out)
|
||||
(write-ulong (+ cmdssz new-cmd-sz) out)
|
||||
(file-position out link-edit-pos)
|
||||
(write-ulong 1 out) ; LC_SEGMENT
|
||||
(write-ulong new-cmd-sz out)
|
||||
(display #"__PLTSCHEME\0\0\0\0\0" out)
|
||||
(write-ulong out-addr out)
|
||||
(write-ulong outlen out)
|
||||
(write-ulong out-offset out)
|
||||
(write-ulong outlen out)
|
||||
(write-ulong 0 out)
|
||||
(write-ulong 0 out)
|
||||
(write-ulong 0 out)
|
||||
(write-ulong 4 out) ; 4 means SG_NORELOC
|
||||
(when move-link-edit?
|
||||
;; Update link-edit segment entry:
|
||||
(when (sym-tab-pos . > . link-edit-pos)
|
||||
(set! sym-tab-pos (+ sym-tab-pos 56)))
|
||||
(when (dysym-pos . > . link-edit-pos)
|
||||
(set! dysym-pos (+ dysym-pos 56)))
|
||||
(when (hints-pos . > . link-edit-pos)
|
||||
(set! hints-pos (+ hints-pos 56)))
|
||||
(set! link-edit-pos (+ link-edit-pos 56))
|
||||
(file-position out (+ link-edit-pos 32))
|
||||
(printf "Update to ~a\n" (+ out-offset outlen))
|
||||
(write-ulong (+ out-offset outlen) out)
|
||||
;; Read link-edit segment:
|
||||
(file-position p link-edit-offset)
|
||||
(let ([link-edit (read-bytes link-edit-len p)])
|
||||
;; Write link-edit data in new location:
|
||||
(file-position out (+ link-edit-offset outlen))
|
||||
(display link-edit out))
|
||||
;; Shift symbol-table pointer:
|
||||
(file-position p (+ sym-tab-pos 8))
|
||||
(let ([symtab-offset (read-ulong p)]
|
||||
[_ (read-ulong p)]
|
||||
[symstr-offset (read-ulong p)])
|
||||
(file-position out (+ sym-tab-pos 8))
|
||||
(write-ulong (+ symtab-offset outlen) out)
|
||||
(file-position out (+ sym-tab-pos 16))
|
||||
(write-ulong (+ symstr-offset outlen) out))
|
||||
;; Shift dysym pointers:
|
||||
(file-position p (+ dysym-pos 56))
|
||||
(let ([ind-offset (read-ulong p)])
|
||||
(file-position out (+ dysym-pos 56))
|
||||
(write-ulong (+ ind-offset outlen) out))
|
||||
;; Shift hints pointer:
|
||||
(file-position p (+ hints-pos 8))
|
||||
(let ([hints-offset (read-ulong p)])
|
||||
(file-position out (+ hints-pos 8))
|
||||
(write-ulong (+ hints-offset outlen) out)))
|
||||
;; Write segdata to former link-data offset:
|
||||
(file-position out out-offset)
|
||||
(display segdata out)
|
||||
(display (make-bytes (- outlen (bytes-length segdata)) 0) out)
|
||||
;; Result is offset where data was written:
|
||||
out-offset)))
|
||||
(let loop ([cnt cnt][base 0][delta 0][result #f])
|
||||
(if (zero? cnt)
|
||||
result
|
||||
(let ([pos (file-position p)]
|
||||
[cmd (read-ulong p)]
|
||||
[sz (read-ulong p)])
|
||||
(case cmd
|
||||
[(#xC)
|
||||
;; LC_LOAD_DYLIB
|
||||
(let ([offset (read-ulong p)])
|
||||
(file-position p (+ pos offset))
|
||||
(let* ([namelen (- sz offset)]
|
||||
[segname (read-bytes namelen p)]
|
||||
[segname (car (regexp-match #rx#"^[^\0]*" segname))])
|
||||
(if (regexp-match rx segname)
|
||||
(let* ([newnamelen (and out
|
||||
(mult-of-4 (+ 1 (bytes-length new-path))))]
|
||||
[delta (if out
|
||||
(- newnamelen namelen)
|
||||
0)])
|
||||
(when out
|
||||
(unless (zero? delta)
|
||||
;; We assume that there's enough header room to
|
||||
;; extend this load command, because the binary
|
||||
;; was linked with -headerpad_max_install_names
|
||||
(file-position out (+ pos 4))
|
||||
(write-ulong (+ sz delta) out)
|
||||
(flush-output out)
|
||||
;; Shift rest of load commands by delta
|
||||
(let ([end cmdssz])
|
||||
(file-position p (+ pos sz))
|
||||
(let ([s (read-bytes (- end (+ pos sz)) p)])
|
||||
(file-position out (+ pos sz delta))
|
||||
(write-bytes s out)
|
||||
(when (negative? delta)
|
||||
;; zero-out now-unneeded space:
|
||||
(write-bytes (make-bytes (- delta) 0) out))
|
||||
(flush-output out))
|
||||
;; Change load-commands size in header:
|
||||
(file-position out 20)
|
||||
(write-ulong (+ end delta) out)
|
||||
(flush-output out)))
|
||||
(file-position out (+ pos offset))
|
||||
(write-bytes new-path out)
|
||||
(write-bytes (make-bytes (- newnamelen (bytes-length new-path)) 0) out)
|
||||
(flush-output out))
|
||||
(file-position p (+ pos sz delta))
|
||||
(loop (sub1 cnt) pos delta segname))
|
||||
(begin
|
||||
(file-position p (+ pos sz))
|
||||
(loop (sub1 cnt) base delta result)))))]
|
||||
[else
|
||||
(file-position p (+ pos sz))
|
||||
(loop (sub1 cnt) base delta result)]))))))
|
||||
(lambda ()
|
||||
(close-input-port p)
|
||||
(close-output-port out))))))
|
||||
(when out
|
||||
(close-output-port out)))))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
(module dirs mzscheme
|
||||
(require (lib "winutf16.ss" "compiler" "private"))
|
||||
(require (lib "winutf16.ss" "compiler" "private")
|
||||
(lib "mach-o.ss" "compiler" "private"))
|
||||
|
||||
(define main-collects-dir
|
||||
(delay
|
||||
|
|
@ -71,11 +72,42 @@
|
|||
(unless m (error "cannot find \"dLl dIRECTORy\" tag in binary"))
|
||||
(let-values ([(dir name dir?) (split-path exe)])
|
||||
(if (regexp-match #rx#"^<" (cadr m))
|
||||
;; no DLL dir in binary, so assume exe dir:
|
||||
dir
|
||||
;; no DLL dir in binary
|
||||
#f
|
||||
;; resolve relative directory:
|
||||
(let ([p (bytes->path (utf-16-bytes->bytes (cadr m)))])
|
||||
(path->complete-path p dir))))))))]
|
||||
[(macosx)
|
||||
(let ([exe (parameterize ([current-directory (find-system-path 'orig-dir)])
|
||||
(let loop ([p (find-executable-path (find-system-path 'exec-file))])
|
||||
(if (link-exists? p)
|
||||
(loop (let-values ([(r) (resolve-path p)]
|
||||
[(dir name dir?) (split-path p)])
|
||||
(if (and (path? dir)
|
||||
(relative-path? r))
|
||||
(build-path dir r)
|
||||
r)))
|
||||
p)))])
|
||||
(let ([rel (get/set-dylib-path exe "PLT_M[rz]" #f)])
|
||||
(if rel
|
||||
(cond
|
||||
[(regexp-match #rx#"^(@executable_path/)?(.*?)PLT_M(?:rEd|zScheme).framework" rel)
|
||||
=> (lambda (m)
|
||||
(let ([b (caddr m)])
|
||||
(if (and (not (cadr m))
|
||||
(bytes=? b #""))
|
||||
#f ; no path in exe
|
||||
(simplify-path
|
||||
(path->complete-path (if (not (cadr m))
|
||||
(bytes->path b)
|
||||
(let-values ([(dir name dir?) (split-path exe)])
|
||||
(if (bytes=? b #"")
|
||||
dir
|
||||
(build-path dir (bytes->path b)))))
|
||||
(find-system-path 'orig-dir))))))]
|
||||
[else (find-lib-dir)])
|
||||
;; no framework reference found!?
|
||||
#f)))]
|
||||
[else
|
||||
(find-lib-dir)])))
|
||||
(define (find-dll-dir)
|
||||
|
|
|
|||
|
|
@ -303,7 +303,8 @@ installation directories:
|
|||
|
||||
Returns a path to the directory that contains DLLs for use with the
|
||||
current executable (e.g., "libmzsch.dll" under Windows). The result
|
||||
is #f if no such directory is available.
|
||||
is #f if no such directory is available, or if no specific directory
|
||||
is available (i.e., other than the platform's normal search path).
|
||||
|
||||
|
||||
_Getting info.ss fields_
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user