1(module distribute racket/base 2 (require racket/file 3 racket/path 4 setup/dirs 5 racket/list 6 setup/variant 7 setup/cross-system 8 pkg/path 9 setup/main-collects 10 "private/macfw.rkt" 11 "private/mach-o.rkt" 12 "private/windlldir.rkt" 13 "private/elf.rkt" 14 "private/collects-path.rkt" 15 "private/write-perm.rkt" 16 "private/win-dll-list.rkt") 17 18 (provide assemble-distribution) 19 20 (define (assemble-distribution dest-dir 21 orig-binaries 22 #:executables? [executables? #t] 23 #:relative-base [relative-base #f] 24 #:collects-path [collects-path #f] ; relative to dest-dir 25 #:copy-collects [copy-collects null]) 26 (let* ([types (if executables? 27 (map get-binary-type orig-binaries) 28 (map (lambda (v) #f) orig-binaries))] 29 [_ (unless (directory-exists? dest-dir) 30 (make-directory dest-dir))] 31 [sub-dirs (map (lambda (b type) 32 (and type 33 (case (cross-system-type) 34 [(windows) #f] 35 [(unix) "bin"] 36 [(macosx) (if (memq type '(gracketcgc gracket3m gracketcs)) 37 #f 38 "bin")]))) 39 orig-binaries 40 types)] 41 ;; Copy binaries into place: 42 [binaries 43 (map (lambda (b sub-dir type) 44 (if type 45 (let ([dest-dir (if sub-dir 46 (build-path dest-dir sub-dir) 47 dest-dir)]) 48 (unless (directory-exists? dest-dir) 49 (make-directory dest-dir)) 50 (let-values ([(base name dir?) (split-path b)]) 51 (let ([dest (build-path dest-dir name)]) 52 (if (and (memq type '(gracketcgc gracket3m gracketcs)) 53 (eq? 'macosx (cross-system-type))) 54 (begin 55 (copy-app b dest) 56 (app-to-file dest)) 57 (begin 58 (copy-file* b dest) 59 dest))))) 60 b)) 61 orig-binaries 62 sub-dirs 63 types)] 64 [old-permss (and executables? 65 (eq? (system-type) 'unix) 66 (for/list ([b (in-list binaries)]) 67 (ensure-writable b)))] 68 [single-mac-app? (and executables? 69 (eq? 'macosx (cross-system-type)) 70 (= 1 (length types)) 71 (memq (car types) '(gracketcgc gracket3m gracketcs)))]) 72 ;; Create directories for libs, collects, and extensions: 73 (let-values ([(lib-dir collects-dir relative-collects-dir exts-dir relative-exts-dir) 74 (if single-mac-app? 75 ;; Special case: single Mac OS GRacket app: 76 (let-values ([(base name dir?) 77 (split-path (car binaries))]) 78 (values 79 (simplify-path (build-path base 'up "Frameworks")) 80 (if collects-path 81 (build-path dest-dir collects-path) 82 (simplify-path (build-path base 83 'up 84 "Resources" 85 "collects"))) 86 (if collects-path 87 (build-path 'up 'up 'up collects-path) 88 (build-path 'up "Resources" "collects")) 89 (build-path base 'up "Resources" "exts") 90 (build-path 'up "Resources" "exts"))) 91 ;; General case: 92 (let* ([specific-lib-dir 93 (build-path "lib" 94 "plt" 95 (if (or (not executables?) 96 (null? binaries)) 97 "generic" 98 (let-values ([(base name dir?) 99 (split-path (car binaries))]) 100 (path-replace-extension name #""))))] 101 [relative-collects-dir 102 (or collects-path 103 (build-path specific-lib-dir 104 "collects"))]) 105 (values (build-path dest-dir "lib") 106 (build-path dest-dir relative-collects-dir) 107 relative-collects-dir 108 (build-path dest-dir specific-lib-dir "exts") 109 (build-path specific-lib-dir "exts"))))]) 110 ;; Copy libs into place 111 (install-libs lib-dir types 112 #:extras-only? (not executables?) 113 #:no-dlls? (and executables? 114 (case (cross-system-type) 115 [(windows) 116 ;; If all executables have "<system>" the the 117 ;; DLL dir, then no base DLLS are needed 118 (for/and ([f (in-list orig-binaries)]) 119 (current-no-dlls? f))] 120 [(macosx) 121 ;; If no executable refers to a "Racket" 122 ;; framework, then they must embed it 123 (for/and ([f (in-list orig-binaries)]) 124 (not (get-current-framework-path (app-to-file f) "Racket")))] 125 [else 126 (not (ormap needs-original-executable? binaries))]))) 127 ;; Copy collections into place 128 (unless (null? copy-collects) (make-directory* collects-dir)) 129 (for-each (lambda (dir) 130 (for-each (lambda (f) 131 (copy-directory/files* 132 (build-path dir f) 133 (build-path collects-dir f))) 134 (directory-list dir))) 135 copy-collects) 136 ;; Remove signatures, if any 137 (when (and executables? (eq? 'macosx (cross-system-type))) 138 (for-each remove-signature binaries)) 139 ;; Patch binaries to find libs 140 (when executables? 141 (patch-binaries binaries types)) 142 (let ([relative->binary-relative 143 (lambda (sub-dir type relative-dir) 144 (cond 145 [relative-base 146 (build-path relative-base relative-dir)] 147 [(not executables?) 148 (build-path dest-dir relative-dir)] 149 [sub-dir 150 (build-path 'up relative-dir)] 151 [(and (eq? 'macosx (cross-system-type)) 152 (memq type '(gracketcgc gracket3m gracketcs)) 153 (not single-mac-app?)) 154 (build-path 'up 'up 'up relative-dir)] 155 [else 156 relative-dir]))]) 157 ;; Patch binaries to find collects 158 (for-each (lambda (b type sub-dir) 159 (when type 160 (set-collects-path 161 b 162 (collects-path->bytes 163 (relative->binary-relative sub-dir type relative-collects-dir))))) 164 binaries types sub-dirs) 165 (unless (null? binaries) 166 ;; Copy over extensions and adjust embedded paths: 167 (copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs 168 exts-dir 169 relative-exts-dir 170 relative->binary-relative) 171 ;; Copy over runtime files and adjust embedded paths: 172 (copy-runtime-files-and-patch-binaries orig-binaries binaries types sub-dirs 173 exts-dir 174 relative-exts-dir 175 relative->binary-relative) 176 ;; Add signatures, if needed 177 (when (and executables? (eq? 'macosx (cross-system-type))) 178 (for-each add-ad-hoc-signature binaries)) 179 ;; Restore executable permissions: 180 (when old-permss 181 (map done-writable binaries old-permss)) 182 ;; Done! 183 (void)))))) 184 185 (define (install-libs lib-dir types 186 #:extras-only? extras-only? 187 #:no-dlls? no-dlls?) 188 (case (cross-system-type) 189 [(windows) 190 (if no-dlls? 191 '() 192 (let ([copy-dll (lambda (name) 193 (make-directory* lib-dir) 194 (copy-file* (search-dll name) 195 (build-path lib-dir name)))]) 196 (map copy-dll (get-racket-dlls types #:extras-only? extras-only?))))] 197 [(macosx) 198 (unless (or extras-only? no-dlls?) 199 (when (or (memq 'racketcgc types) 200 (memq 'gracketcgc types)) 201 (copy-framework "Racket" 'cgc lib-dir)) 202 (when (or (memq 'racket3m types) 203 (memq 'gracket3m types)) 204 (copy-framework "Racket" '3m lib-dir)) 205 (when (or (memq 'racketcs types) 206 (memq 'gracketcs types)) 207 (copy-framework "Racket" 'cs lib-dir)))] 208 [(unix) 209 (unless (or extras-only? 210 (and no-dlls? 211 (not (shared-libraries?)))) 212 (let ([lib-plt-dir (build-path lib-dir "plt")]) 213 (let ([copy-bin 214 (lambda (name variant gr?) 215 (make-directory* lib-plt-dir) 216 (copy-file* (build-path (if gr? 217 (find-lib-dir) 218 (find-console-bin-dir)) 219 (format "~a~a" name (variant-suffix variant #f))) 220 (build-path lib-plt-dir 221 (format "~a~a-~a" name variant (version)))))]) 222 (when (memq 'racketcgc types) 223 (copy-bin "racket" 'cgc #f)) 224 (when (memq 'racket3m types) 225 (copy-bin "racket" '3m #f)) 226 (when (memq 'racketcs types) 227 (copy-bin "racket" 'cs #f)) 228 (when (memq 'gracketcgc types) 229 (copy-bin "gracket" 'cgc #t)) 230 (when (memq 'gracket3m types) 231 (copy-bin "gracket" '3m #t)) 232 (when (memq 'gracketcs types) 233 (copy-bin "gracket" 'cs #t))) 234 (when (shared-libraries?) 235 (when (or (memq 'racketcgc types) 236 (memq 'gracketcgc types)) 237 (copy-shared-lib "racket" lib-dir) 238 (copy-shared-lib "mzgc" lib-dir)) 239 (when (or (memq 'racket3m types) 240 (memq 'gracket3m types)) 241 (copy-shared-lib "racket3m" lib-dir)) 242 (when (or (memq 'racketcs types) 243 (memq 'gracketcs types)) 244 (copy-shared-lib "racketcs" lib-dir)))))])) 245 246 (define (copy-framework name variant lib-dir) 247 (let* ([fw-name (format "~a.framework" name)] 248 [sub-dir (build-path fw-name "Versions" 249 (case variant 250 [(3m) (format "~a_3m" (version))] 251 [(cs) (format "~a_CS" (version))] 252 [else (version)]))]) 253 (make-directory* (build-path lib-dir sub-dir)) 254 (let* ([fw-name (build-path sub-dir (format "~a" name))] 255 [dll-dir (find-framework fw-name)]) 256 (copy-file* (build-path dll-dir fw-name) 257 (build-path lib-dir fw-name)) 258 (let ([boot-src (build-path dll-dir sub-dir "boot")]) 259 (when (directory-exists? boot-src) 260 (copy-directory/files* 261 boot-src 262 (build-path lib-dir sub-dir "boot")))) 263 (let ([rsrc-src (build-path dll-dir sub-dir "Resources")]) 264 (when (directory-exists? rsrc-src) 265 (copy-directory/files* 266 rsrc-src 267 (build-path lib-dir sub-dir "Resources"))))))) 268 269 (define (find-framework fw-name) 270 (let ([dll-dir (find-cross-dll-dir)]) 271 (or dll-dir 272 (ormap (lambda (p) 273 (let ([f (build-path p fw-name)]) 274 (and (file-exists? f) 275 p))) 276 '("/System/Library/Frameworks" 277 "/Library/Frameworks" 278 "~/Library/Frameworks")) 279 ;; Can't find it, so just use relative path: 280 (build-path 'same)))) 281 282 ;; cache: 283 (define avail-lib-files #f) 284 285 (define (copy-shared-lib name lib-dir) 286 (make-directory* lib-dir) 287 (unless avail-lib-files 288 (set! avail-lib-files (directory-list (find-cross-dll-dir)))) 289 (let* ([rx (byte-regexp (string->bytes/latin-1 290 (format "lib~a-~a.*[.](?:so|dylib)$" name (version))))] 291 [files (filter (lambda (f) 292 (regexp-match rx (path->bytes f))) 293 avail-lib-files)]) 294 (when (null? files) 295 (error 'copy-shared-lib "cannot find shared library for ~a" 296 name)) 297 (unless (null? (cdr files)) 298 (error 'copy-shared-lib 299 "found multiple shared-library candidates for ~a: ~e" 300 name 301 files)) 302 (copy-file* (build-path (find-cross-dll-dir) (car files)) 303 (build-path lib-dir (car files))))) 304 305 (define (patch-binaries binaries types) 306 (case (cross-system-type) 307 [(windows) 308 (for-each (lambda (b) 309 (unless (current-no-dlls? b) 310 (update-dll-dir b "lib"))) 311 binaries)] 312 [(macosx) 313 (if (and (= 1 (length types)) 314 (memq (car types) '(gracketcgc gracket3m gracketcs))) 315 ;; Special case for single GRacket app: 316 (update-framework-path "@executable_path/../Frameworks/" 317 (car binaries) 318 #t) 319 ;; General case: 320 (for-each (lambda (b type) 321 (update-framework-path (if (memq type '(racketcgc racket3m racketcs)) 322 "@executable_path/../lib/" 323 "@executable_path/../../../lib/" ) 324 b 325 (memq type '(gracketcgc gracket3m gracketcs)))) 326 binaries types))] 327 [(unix) 328 (for-each (lambda (b type) 329 (when (needs-original-executable? b) 330 (patch-stub-exe-paths b 331 (build-path 332 "../lib/plt" 333 (format "~a-~a" type (version))) 334 (and (shared-libraries?) 335 "../lib")))) 336 binaries 337 types)])) 338 339 (define (patch-stub-exe-paths b exe shared-lib-dir) 340 ;; Adjust paths to executable and DLL that is embedded in the executable 341 (define rx:rackprog #rx#"^[.]rackprog\0") 342 (define section-offset+size (get-racket-section-offset+size b rx:rackprog)) 343 (define section-offset (if section-offset+size 344 (car section-offset+size) 345 0)) 346 (let-values ([(config-pos all-start start end prog-len dll-len rest) 347 (with-input-from-file b 348 (lambda () 349 (let* ([i (current-input-port)] 350 [m (regexp-match-positions #rx#"cOnFiG:" i)]) 351 (unless m 352 (error 'patch-stub-exe-paths 353 "cannot find config info")) 354 (read-byte i) 355 (define all-start (read-one-int i)) ; start of decls 356 (read-one-int i) ; start of program 357 (let ([start (read-one-int i)] ; start of data 358 [end (read-one-int i)]) ; end of data 359 (file-position i (+ start section-offset)) 360 (let ([prog-len (next-bytes-length i)] 361 [dll-len (next-bytes-length i)]) 362 (values (+ (cdar m) 1) ; position after "cOnFiG:[" tag 363 all-start 364 start 365 end 366 prog-len 367 dll-len 368 (read-bytes (- (- end start) prog-len dll-len))))))))]) 369 (let ([exe-bytes (path->bytes (to-path exe))] 370 [shared-lib-bytes (if shared-lib-dir 371 (path->bytes (to-path shared-lib-dir)) 372 #"")]) 373 (let ([delta (- (+ prog-len dll-len) 374 (add1 (bytes-length exe-bytes)) 375 (add1 (bytes-length shared-lib-bytes)))]) 376 (with-output-to-file b 377 #:exists 'update 378 (lambda () 379 (let ([o (current-output-port)]) 380 (file-position o (+ config-pos 12)) ; update the end of the program data 381 (write-one-int (- end delta) o) 382 (flush-output o) 383 (file-position o (+ start section-offset)) 384 (write-bytes exe-bytes o) 385 (write-bytes #"\0" o) 386 (write-bytes shared-lib-bytes o) 387 (write-bytes #"\0" o) 388 (write-bytes rest o) 389 (flush-output o)))) 390 ;; May need to fix the size of the ELF section: 391 (adjust-racket-section-size 392 b 393 rx:rackprog 394 (- (- end all-start) delta)))))) 395 396 (define (copy-and-patch-binaries copy? magic 397 extract-src construct-dest transform-entry 398 init-counter inc-counter 399 orig-binaries binaries types sub-dirs 400 exts-dir relative-exts-dir 401 relative->binary-relative) 402 (let loop ([orig-binaries orig-binaries] 403 [binaries binaries] 404 [types types] 405 [sub-dirs sub-dirs] 406 [counter init-counter]) 407 (unless (null? binaries) 408 (let-values ([(exts start-pos end-pos) 409 (with-input-from-file (car binaries) 410 (lambda () 411 (let* ([i (current-input-port)] 412 [m (regexp-match-positions magic i)]) 413 (if m 414 ;; Read table: 415 (begin 416 (file-position i (cdar m)) 417 (let ([l (read i)]) 418 (values (cadr l) (cdar m) (file-position i)))) 419 ;; No table: 420 (values null #f #f)))))]) 421 (if (null? exts) 422 (loop (cdr orig-binaries) (cdr binaries) (cdr types) (cdr sub-dirs) counter) 423 (let-values ([(new-exts counter) 424 ;; Copy over the extensions for this binary, generating a separate path 425 ;; for each executable 426 (let loop ([exts exts][counter counter]) 427 (cond 428 [(null? exts) (values null counter)] 429 [(and (pair? (car (car exts))) 430 (pair? (cdar (car exts))) 431 (eq? 'module (cadar (car exts)))) 432 (let-values ([(rest-exts counter) 433 (loop (cdr exts) counter)]) 434 (values (cons (car exts) rest-exts) counter))] 435 [else 436 (let* ([src (extract-src (car exts) (car orig-binaries))] 437 [dest (construct-dest src)] 438 [sub (format "e~a" counter)]) 439 (when (and src copy?) 440 ; Make dest and copy 441 (make-directory* (build-path exts-dir sub (or (path-only dest) 'same))) 442 (let ([f (build-path exts-dir sub dest)]) 443 (when (or (file-exists? f) 444 (directory-exists? f) 445 (link-exists? f)) 446 (delete-directory/files f)) 447 (copy-directory/files src f))) 448 ;; Generate the new extension entry for the table, and combine with 449 ;; recur result for the rest: 450 (let-values ([(rest-exts counter) 451 (loop (cdr exts) (inc-counter counter))]) 452 (values (if src 453 (cons (transform-entry 454 (relative->binary-relative (car sub-dirs) 455 (car types) 456 (build-path relative-exts-dir sub dest)) 457 (car exts)) 458 rest-exts) 459 (cons (car exts) 460 rest-exts)) 461 counter)))]))]) 462 (when copy? 463 ;; Update the binary with the new paths 464 (let* ([str (string->bytes/utf-8 (format "~s" new-exts))] 465 [extra-space 7] ; = "(quote" plus ")" 466 [delta (- (- end-pos start-pos) (bytes-length str) extra-space)]) 467 (when (negative? delta) 468 (error 'copy-and-patch-binaries 469 "not enough room in executable for revised ~s table" 470 magic)) 471 (with-output-to-file (car binaries) 472 #:exists 'update 473 (lambda () 474 (let ([o (current-output-port)]) 475 (file-position o start-pos) 476 (write-bytes #"(quote" o) 477 (write-bytes str o) 478 ;; Add space before final closing paren. This preserves space in case the 479 ;; genereated binary is input for a future distribution build. 480 (write-bytes (make-bytes delta (char->integer #\space)) o) 481 (write-bytes #")" o)))))) 482 (loop (cdr orig-binaries) (cdr binaries) (cdr types) (cdr sub-dirs) counter))))))) 483 484 (define (copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs 485 exts-dir relative-exts-dir 486 relative->binary-relative) 487 (copy-and-patch-binaries #t #rx#"eXtEnSiOn-modules[)]" 488 ;; extract-src: 489 (lambda (ext orig-binary) 490 (path->complete-path 491 (bytes->path (car ext)) 492 (let-values ([(base name dir?) 493 (split-path (path->complete-path orig-binary 494 (current-directory)))]) 495 base))) 496 ;; construct-dest: 497 (lambda (src) 498 (let-values ([(base name dir?) (split-path src)]) 499 name)) 500 ;; transform-entry 501 (lambda (new-path ext) 502 (list (path->cross-bytes new-path) (cadr ext))) 503 0 add1 ; <- counter 504 orig-binaries binaries types sub-dirs 505 exts-dir relative-exts-dir 506 relative->binary-relative)) 507 508 (define (copy-runtime-files-and-patch-binaries orig-binaries binaries types sub-dirs 509 exts-dir relative-exts-dir 510 relative->binary-relative) 511 (define pkg-path-cache (make-hash)) 512 (let ([paths null]) 513 ;; Pass 1: collect all the paths 514 (copy-and-patch-binaries #f #rx#"rUnTiMe-paths[)]" 515 ;; extract-src: 516 (lambda (rt orig-binary) 517 (and (cadr rt) 518 (bytes? (cadr rt)) 519 (bytes->path (cadr rt)))) 520 ;; construct-dest: 521 (lambda (src) 522 (when src 523 (set! paths (cons (normal-case-path src) paths))) 524 "dummy") 525 ;; transform-entry 526 (lambda (new-path ext) ext) 527 "rt" values ; <- counter 528 orig-binaries binaries types sub-dirs 529 exts-dir relative-exts-dir 530 relative->binary-relative) 531 (unless (null? paths) 532 ;; Determine the shared path prefix among paths within a package, 533 ;; "collects" directory, or other root. That way, relative path references 534 ;; can work, but we don't keep excessive path information from the 535 ;; build machine. 536 (let* ([root-table (make-hash)] 537 [root->path-element (lambda (root) 538 (hash-ref root-table 539 root 540 (lambda () 541 (let ([v (format "r~a" (hash-count root-table))]) 542 (hash-set! root-table root v) 543 v))))] 544 [alt-paths (map explode-path 545 (map normal-case-path 546 (list* (find-system-path 'addon-dir) 547 (find-share-dir) 548 (append (get-cross-lib-search-dirs) 549 (get-include-search-dirs)))))] 550 [explode (lambda (src) 551 ;; Sort the path into a root, and keep the root plus 552 ;; the part of the path relative to that root: 553 (define-values (pkg subpath) 554 (path->pkg+subpath src #:cache pkg-path-cache)) 555 (define main 556 (and (not pkg) 557 (path->main-collects-relative src))) 558 (define other (and (not pkg) 559 (not (pair? main)) 560 (let ([e (explode-path src)]) 561 (for/or ([d (in-list alt-paths)] 562 [i (in-naturals)]) 563 (define len (length d)) 564 (and ((length e) . > . len) 565 (equal? d (take e len)) 566 (cons i len)))))) 567 (reverse 568 (let loop ([src (cond 569 [pkg subpath] 570 [(pair? main) 571 (apply build-path 572 (map bytes->path-element (cdr main)))] 573 [other (apply build-path 574 (list-tail (explode-path src) (cdr other)))] 575 [else src])]) 576 (let-values ([(base name dir?) (split-path src)]) 577 (cond 578 [(path? base) 579 (cons name (loop base))] 580 [(or pkg 581 (and (pair? main) 582 'collects) 583 (and other (car other))) 584 => (lambda (r) 585 (list name (root->path-element r)))] 586 [else 587 (list (root->path-element name))])))))] 588 ;; In reverse order, so we can pick off the paths 589 ;; in the second pass: 590 [exploded (reverse (let ([exploded (map explode paths)]) 591 ;; For paths that share the same root, 592 ;; drop any common "prefix" after the root. 593 (define roots-common 594 (for/fold ([ht (hash)]) ([e (in-list exploded)]) 595 (define l (hash-ref ht (car e) #f)) 596 (hash-set ht (car e) 597 (if (not l) 598 (cdr e) 599 (let loop ([l l] [l2 (cdr e)]) 600 (cond 601 [(or (null? l) (null? l2)) null] 602 [(or (null? l) (null? l2)) null] 603 [(equal? (car l) (car l2)) 604 (cons (car l) (loop (cdr l) (cdr l2)))] 605 [else null])))))) 606 ;; Drop common parts out, but deefinitely keep the last 607 ;; element: 608 (for/list ([e (in-list exploded)]) 609 (define l (hash-ref roots-common (car e) null)) 610 (cons (car e) (list-tail (cdr e) (max 0 (sub1 (length l))))))))]) 611 612 ;; Pass 2: change all the paths 613 (copy-and-patch-binaries #t #rx#"rUnTiMe-paths[)]" 614 ;; extract-src: 615 (lambda (rt orig-binary) 616 (and (cadr rt) 617 (bytes->path (cadr rt)))) 618 ;; construct-dest: 619 (lambda (src) 620 (and src 621 (begin0 622 (apply build-path (car exploded)) 623 (set! exploded (cdr exploded))))) 624 ;; transform-entry 625 (lambda (new-path ext) 626 (cons (car ext) (list (path->cross-bytes new-path)))) 627 "rt" values ; <- counter 628 orig-binaries binaries types sub-dirs 629 exts-dir relative-exts-dir 630 relative->binary-relative))))) 631 632 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 633 ;; Utilities 634 635 (define (shared-libraries?) 636 (eq? 'shared (cross-system-type 'link))) 637 638 (define (to-path s) 639 (if (string? s) 640 (string->path s) 641 s)) 642 643 (define (path->cross-bytes p) 644 (define cross-convention 645 ;; it would be nice to have `cross-system-path-convention`: 646 (case (cross-system-type) 647 [(windows) 'windows] 648 [else 'unix])) 649 (cond 650 [(eq? cross-convention (system-path-convention-type)) (path->bytes p)] 651 [else 652 (let loop ([p p] [accum '()]) 653 (define-values (base name dir?) (split-path p)) 654 (define new-accum (cons (if (path? name) 655 (bytes->path-element (path-element->bytes name) 656 cross-convention) 657 name) 658 accum)) 659 (cond 660 [(eq? base 'relative) (path->bytes (apply build-path/convention-type 661 cross-convention 662 new-accum))] 663 [else (loop base new-accum)]))])) 664 665 (define (get-binary-type b) 666 ;; Since this is called first, we also check that the executable 667 ;; is a stub binary for Unix or doesn't depend on shared libraries. 668 (with-input-from-file (app-to-file b) 669 (lambda () 670 (let ([m (regexp-match #rx#"bINARy tYPe:(e?)(.)(.)(.)" (current-input-port))]) 671 (if m 672 (begin 673 (when (eq? 'unix (cross-system-type)) 674 (unless (or (equal? (cadr m) #"e") 675 (not (shared-libraries?))) 676 (error 'assemble-distribution 677 "file is an original PLT executable that relies on a shared library: ~e" 678 b))) 679 (let ([variant (case (list-ref m 4) 680 [(#"3") '3m] 681 [(#"s") 'cs] 682 [else 'cgc])]) 683 (if (equal? (caddr m) #"r") 684 (case variant 685 [(3m) 'gracket3m] 686 [(cs) 'gracketcs] 687 [else 'gracketcgc]) 688 (case variant 689 [(3m) 'racket3m] 690 [(cs) 'racketcs] 691 [else 'racketcgc])))) 692 (error 'assemble-distribution 693 "file is not a PLT executable: ~e" 694 b)))))) 695 696 (define (needs-original-executable? b) 697 (and (eq? 'unix (cross-system-type)) 698 (with-input-from-file (app-to-file b) 699 (lambda () 700 (let ([m (regexp-match #rx#"bINARy tYPe:(e?)" (current-input-port))]) 701 (equal? (cadr m) #"e")))))) 702 703 (define (write-one-int n out) 704 (write-bytes (integer->integer-bytes n 4 #t #f) out)) 705 706 (define (read-one-int in) 707 (integer-bytes->integer (read-bytes 4 in) #t #f)) 708 709 (define (next-bytes-length in) 710 (let ([m (regexp-match-positions #rx#"\0" in)]) 711 (cdar m))) 712 713 (define (copy-file* src dest) 714 (when (or (file-exists? dest) 715 (link-exists? dest)) 716 (delete-file dest)) 717 (copy-file src dest) 718 (let ([t (file-or-directory-modify-seconds src)]) 719 (file-or-directory-modify-seconds dest t))) 720 721 (define (copy-directory/files* src dest) 722 (cond 723 [(directory-exists? src) 724 (unless (directory-exists? dest) 725 (make-directory dest)) 726 (for-each (lambda (f) 727 (copy-directory/files* (build-path src f) 728 (build-path dest f))) 729 (directory-list src))] 730 [else 731 (copy-file* src dest)])) 732 733 (define (copy-app src dest) 734 (when (or (file-exists? dest) 735 (directory-exists? dest) 736 (link-exists? dest)) 737 (delete-directory/files dest)) 738 (copy-directory/files src dest)) 739 740 (define (app-to-file b) 741 (if (and (eq? 'macosx (cross-system-type)) 742 (directory-exists? b) 743 (regexp-match #rx#"[.][aA][pP][pP]$" 744 (path->bytes (if (string? b) 745 (string->path b) 746 b)))) 747 (let ([no-app 748 (let-values ([(base name dir?) (split-path b)]) 749 (path-replace-extension name #""))]) 750 (build-path b "Contents" "MacOS" no-app)) 751 b))) 752