directly manipulate mach-o to change framework path or to add code for a stand-alone executable

svn: r2937

collects/compiler/embed-unit.ss

@@ -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)])
+		(let ([write-module
-		  (with-output-to-file dest-exe
 		       (lambda ()
-		      (write-module-bundle verbose? modules literal-files literal-expression))
+			 (write-module-bundle verbose? modules literal-files literal-expression))])
-		    'append)
+		  (let-values ([(start end)
-		  (let ([end (file-size dest-exe)])
+				(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)]

collects/compiler/private/macfw.ss

@@ -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,42 +22,35 @@
 		  (let* ([orig (get-current-framework-path dest p)]
 			 [3m (if (and orig (regexp-match #rx"_3m" orig))
 				 "_3m"
-				 "")])
+				 "")]
-		    (system* "/usr/bin/install_name_tool"
+			 [old-path (or orig
-			     "-change"
+				       (format "~a.framework/Versions/~a~a/~a" p (version) 3m p))]
-			     (or orig
+			 [new-path (format "~a~a.framework/Versions/~a~a/~a" 
-				 (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)
+					   p (version) 3m p)])
-			     dest)))
+		    (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)])
+    (let ([v (get/set-dylib-path dest
-      (parameterize ([current-output-port w])
+				 (byte-regexp (string->bytes/utf-8 p))
-	(system* "/usr/bin/otool"
+				 #f)])
-		 "-L"
+      (if v
-		 (if (path? dest)
+	  (bytes->string/utf-8 v)
-		     (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))))))
+	    #f)))))
-
 
 
 

collects/compiler/private/mach-o.ss

@@ -1,12 +1,13 @@
 (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)
@@ -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"
+				 ;; (printf "    ~s,~s 0x~x 0x~x\n" seg sect offset vmsz)
-					 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 (fix-offset p pos out d base delta)
-  (define (get/set-dylib-path rx new-path)
+    (when (and out (not (zero? delta)))
-    (let-values ([(p out) (open-input-output-file file 'update)])
+      (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)]
+		   [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)
 	      (read-ulong p)
-	      (let loop ([cnt cnt])
+	      (let loop ([cnt cnt][base 0][delta 0][result #f])
-		(unless (zero? cnt)
+		(if (zero? cnt)
+		    result
 		    (let ([pos (file-position p)]
 			  [cmd (read-ulong p)]
 			  [sz (read-ulong p)])
-		    (printf "~x (~a)\n" cmd sz)
 		      (case cmd
-		      [(1)
+			[(#xC)
-		       ;; Segment
+			 ;; LC_LOAD_DYLIB
-		       (let ([segname (read-bytes 16 p)]
+			 (let ([offset (read-ulong p)])
-			     [vmaddr (read-ulong p)]
+			   (file-position p (+ pos offset))
-			     [vmlen (read-ulong p)]
+			   (let* ([namelen (- sz offset)]
-			     [offset (read-ulong p)]
+				  [segname (read-bytes namelen p)]
-			     [len (read-ulong p)])
+				  [segname (car (regexp-match #rx#"^[^\0]*" segname))])
-			 (printf "~s\n" segname)
+			     (if (regexp-match rx segname)
-			 (when (equal? segname #"__LINKEDIT\0\0\0\0\0\0")
+				 (let* ([newnamelen (and out
-			   (set! link-edit-pos pos)
+							 (mult-of-4 (+ 1 (bytes-length new-path))))]
-			   (set! link-edit-addr vmaddr)
+					[delta (if out
-			   (set! link-edit-offset offset)
+						   (-  newnamelen namelen)
-			   (set! link-edit-len len))
+						   0)])
-			 (printf "  0x~x 0x~x -> 0x~x 0x~x\n" offset len vmaddr vmlen)
+				   (when out
-			 (read-ulong p)
+				     (unless (zero? delta)
-			 (read-ulong p)
+				       ;; We assume that there's enough header room to
-			 (let ([nsects (read-ulong p)])
+				       ;; extend this load command, because the binary
-			   (read-ulong p)
+				       ;; was linked with -headerpad_max_install_names
-			   (let loop ([nsects nsects])
+				       (file-position out (+ pos 4))
-			     (unless (zero? nsects)
+				       (write-ulong (+ sz delta) out)
-			       (let ([sect (read-bytes 16 p)]
+				       (flush-output out)
-				     [seg (read-bytes 16 p)]
+				       ;; Shift rest of load commands by delta
-				     [vmaddr (read-ulong p)]
+				       (let ([end cmdssz])
-				     [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)))))
+					 (let ([s (read-bytes (- end (+ pos sz)) p)])
-	      (printf "Start offset: 0x~x\n" min-used)
+					   (file-position out (+ pos sz delta))
-	      (let ([end-cmd (+ cmdssz 28)]
+					   (write-bytes s out)
-		    [new-cmd-sz 56]
+					   (when (negative? delta)
-		    [outlen (round-up-page (bytes-length segdata))]
+					     ;; zero-out now-unneeded space:
-		    [out-offset (if move-link-edit?
+					     (write-bytes (make-bytes (- delta) 0) out))
-				    link-edit-offset
+					   (flush-output out))
-				    (+ link-edit-offset (round-up-page link-edit-len)))]
+					 ;; Change load-commands size in header:
-		    [out-addr (+ link-edit-addr (round-up-page link-edit-len))])
+					 (file-position out 20)
-		(unless ((+ end-cmd new-cmd-sz) . < . min-used)
+					 (write-ulong (+ end delta) out)
-		  (error 'check-header "no room for a new section load command"))
+					 (flush-output out)))
-		;; Shift commands after link-edit segment:
+				     (file-position out (+ pos offset))
-		(file-position p link-edit-pos)
+				     (write-bytes new-path out)
-		(let ([s (read-bytes (- end-cmd link-edit-pos) p)])
+				     (write-bytes (make-bytes (- newnamelen (bytes-length new-path)) 0) out)
-		  (file-position out (+ link-edit-pos 56))
+				     (flush-output out))
-		  (display s out))
+				   (file-position p (+ pos sz delta))
-		(file-position out 16)
+				   (loop (sub1 cnt) pos delta segname))
-		;; The segment:
+				 (begin
-		(write-ulong (+ cnt 1) out)
+				   (file-position p (+ pos sz))
-		(write-ulong (+ cmdssz new-cmd-sz) out)
+				   (loop (sub1 cnt) base delta result)))))]
-		(file-position out link-edit-pos)
+			[else
-		(write-ulong 1 out) ; LC_SEGMENT
+			 (file-position p (+ pos sz))
-		(write-ulong new-cmd-sz out)
+			 (loop (sub1 cnt) base delta result)]))))))
-		(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)))
 	  (lambda ()
 	    (close-input-port p)
-	    (close-output-port out))))))
+	    (when out
+	      (close-output-port out)))))))

collects/setup/dirs.ss

@@ -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:
+			    ;; no DLL dir in binary
-			    dir
+			    #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)

collects/setup/doc.txt

@@ -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_