35a093469c
Enable extflonums in a MSVC build by relying on a MinGW-built DLL, "longdouble.dll". The DLL is loaded on startup. If the DLL isn't available, then `extflonum-available?' reports #f. Instead of setting the floating-point mode globally to extended precision, the mode is changed only just before (and restored right after) extflonum arithmetic operations.
623 lines
25 KiB
Racket
623 lines
25 KiB
Racket
(module distribute scheme/base
|
|
(require scheme/file
|
|
scheme/path
|
|
setup/dirs
|
|
mzlib/list
|
|
setup/variant
|
|
dynext/filename-version
|
|
"private/macfw.rkt"
|
|
"private/windlldir.rkt"
|
|
"private/collects-path.rkt")
|
|
|
|
(provide assemble-distribution)
|
|
|
|
(define (assemble-distribution dest-dir
|
|
orig-binaries
|
|
#:collects-path [collects-path #f] ; relative to dest-dir
|
|
#:copy-collects [copy-collects null])
|
|
(let* ([types (map get-binary-type orig-binaries)]
|
|
[_ (unless (directory-exists? dest-dir)
|
|
(make-directory dest-dir))]
|
|
[sub-dirs (map (lambda (b type)
|
|
(case (system-type)
|
|
[(windows) #f]
|
|
[(unix) "bin"]
|
|
[(macosx) (if (memq type '(gracketcgc gracket3m))
|
|
#f
|
|
"bin")]))
|
|
orig-binaries
|
|
types)]
|
|
;; Copy binaries into place:
|
|
[binaries
|
|
(map (lambda (b sub-dir type)
|
|
(let ([dest-dir (if sub-dir
|
|
(build-path dest-dir sub-dir)
|
|
dest-dir)])
|
|
(unless (directory-exists? dest-dir)
|
|
(make-directory dest-dir))
|
|
(let-values ([(base name dir?) (split-path b)])
|
|
(let ([dest (build-path dest-dir name)])
|
|
(if (and (memq type '(gracketcgc gracket3m))
|
|
(eq? 'macosx (system-type)))
|
|
(begin
|
|
(copy-app b dest)
|
|
(app-to-file dest))
|
|
(begin
|
|
(copy-file* b dest)
|
|
dest))))))
|
|
orig-binaries
|
|
sub-dirs
|
|
types)]
|
|
[single-mac-app? (and (eq? 'macosx (system-type))
|
|
(= 1 (length types))
|
|
(memq (car types) '(gracketcgc gracket3m)))])
|
|
;; Create directories for libs, collects, and extensions:
|
|
(let-values ([(lib-dir collects-dir relative-collects-dir exts-dir relative-exts-dir)
|
|
(if single-mac-app?
|
|
;; Special case: single Mac OS X GRacket app:
|
|
(let-values ([(base name dir?)
|
|
(split-path (car binaries))])
|
|
(values
|
|
(simplify-path (build-path base 'up "Frameworks"))
|
|
(if collects-path
|
|
(build-path dest-dir collects-path)
|
|
(simplify-path (build-path base
|
|
'up
|
|
"Resources"
|
|
"collects")))
|
|
(if collects-path
|
|
(build-path 'up 'up 'up collects-path)
|
|
(build-path 'up "Resources" "collects"))
|
|
(build-path base 'up "Resources" "exts")
|
|
(build-path 'up "Resources" "exts")))
|
|
;; General case:
|
|
(let* ([specific-lib-dir
|
|
(build-path "lib"
|
|
"plt"
|
|
(if (null? binaries)
|
|
"generic"
|
|
(let-values ([(base name dir?)
|
|
(split-path (car binaries))])
|
|
(path-replace-suffix name #""))))]
|
|
[relative-collects-dir
|
|
(or collects-path
|
|
(build-path specific-lib-dir
|
|
"collects"))])
|
|
(values (build-path dest-dir "lib")
|
|
(build-path dest-dir relative-collects-dir)
|
|
relative-collects-dir
|
|
(build-path dest-dir specific-lib-dir "exts")
|
|
(build-path specific-lib-dir "exts"))))])
|
|
(make-directory* lib-dir)
|
|
(make-directory* collects-dir)
|
|
(make-directory* exts-dir)
|
|
;; Copy libs into place
|
|
(install-libs lib-dir types)
|
|
;; Copy collections into place
|
|
(for-each (lambda (dir)
|
|
(for-each (lambda (f)
|
|
(copy-directory/files*
|
|
(build-path dir f)
|
|
(build-path collects-dir f)))
|
|
(directory-list dir)))
|
|
copy-collects)
|
|
;; Patch binaries to find libs
|
|
(patch-binaries binaries types)
|
|
(let ([relative->binary-relative
|
|
(lambda (sub-dir type relative-dir)
|
|
(cond
|
|
[sub-dir
|
|
(build-path 'up relative-dir)]
|
|
[(and (eq? 'macosx (system-type))
|
|
(memq type '(gracketcgc gracket3m))
|
|
(not single-mac-app?))
|
|
(build-path 'up 'up 'up relative-dir)]
|
|
[else
|
|
relative-dir]))])
|
|
;; Patch binaries to find collects
|
|
(for-each (lambda (b type sub-dir)
|
|
(set-collects-path
|
|
b
|
|
(collects-path->bytes
|
|
(relative->binary-relative sub-dir type relative-collects-dir))))
|
|
binaries types sub-dirs)
|
|
(unless (null? binaries)
|
|
;; Copy over extensions and adjust embedded paths:
|
|
(copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs
|
|
exts-dir
|
|
relative-exts-dir
|
|
relative->binary-relative)
|
|
;; Copy over runtime files and adjust embedded paths:
|
|
(copy-runtime-files-and-patch-binaries orig-binaries binaries types sub-dirs
|
|
exts-dir
|
|
relative-exts-dir
|
|
relative->binary-relative)
|
|
;; Done!
|
|
(void))))))
|
|
|
|
(define (install-libs lib-dir types)
|
|
(case (system-type)
|
|
[(windows)
|
|
(let ([copy-dll (lambda (name)
|
|
(copy-file* (search-dll (find-dll-dir) name)
|
|
(build-path lib-dir name)))]
|
|
[versionize (lambda (template)
|
|
(let ([f (search-dll (find-dll-dir)
|
|
(format template filename-version-part))])
|
|
(if (file-exists? f)
|
|
(format template filename-version-part)
|
|
(format template "xxxxxxx"))))])
|
|
(map copy-dll (list
|
|
(if (equal? "win32\\x86_64" (path->string (system-library-subpath #f)))
|
|
"libiconv-2.dll"
|
|
"iconv.dll")
|
|
"longdouble.dll"))
|
|
(when (or (memq 'racketcgc types)
|
|
(memq 'gracketcgc types))
|
|
(map copy-dll
|
|
(list
|
|
(versionize "libracket~a.dll")
|
|
(versionize "libmzgc~a.dll"))))
|
|
(when (or (memq 'racket3m types)
|
|
(memq 'gracket3m types))
|
|
(map copy-dll
|
|
(list
|
|
(versionize "libracket3m~a.dll")))))]
|
|
[(macosx)
|
|
(when (or (memq 'racketcgc types)
|
|
(memq 'gracketcgc types))
|
|
(copy-framework "Racket" #f lib-dir))
|
|
(when (or (memq 'racket3m types)
|
|
(memq 'gracket3m types))
|
|
(copy-framework "Racket" #t lib-dir))]
|
|
[(unix)
|
|
(let ([lib-plt-dir (build-path lib-dir "plt")])
|
|
(unless (directory-exists? lib-plt-dir)
|
|
(make-directory lib-plt-dir))
|
|
(let ([copy-bin
|
|
(lambda (name variant)
|
|
(copy-file* (build-path (find-console-bin-dir)
|
|
(format "~a~a" name (variant-suffix variant #f)))
|
|
(build-path lib-plt-dir
|
|
(format "~a~a-~a" name variant (version)))))])
|
|
(when (memq 'racketcgc types)
|
|
(copy-bin "racket" 'cgc))
|
|
(when (memq 'racket3m types)
|
|
(copy-bin "racket" '3m))
|
|
(when (memq 'gracketcgc types)
|
|
(copy-bin "gracket" 'cgc))
|
|
(when (memq 'gracket3m types)
|
|
(copy-bin "gracket" '3m)))
|
|
(when (shared-libraries?)
|
|
(when (or (memq 'racketcgc types)
|
|
(memq 'gracketcgc types))
|
|
(copy-shared-lib "racket" lib-dir)
|
|
(copy-shared-lib "mzgc" lib-dir))
|
|
(when (or (memq 'racket3m types)
|
|
(memq 'gracket3m types))
|
|
(copy-shared-lib "racket3m" lib-dir))))]))
|
|
|
|
(define (search-dll dll-dir dll)
|
|
(if dll-dir
|
|
(build-path dll-dir dll)
|
|
(let* ([exe-dir
|
|
(let ([exec (path->complete-path
|
|
(find-executable-path (find-system-path 'exec-file))
|
|
(find-system-path 'orig-dir))])
|
|
(let-values ([(base name dir?) (split-path exec)])
|
|
base))]
|
|
[paths (cons
|
|
exe-dir
|
|
(path-list-string->path-list
|
|
(or (getenv "PATH") "")
|
|
(list (find-system-path 'sys-dir))))])
|
|
(or (ormap (lambda (p)
|
|
(let ([p (build-path p dll)])
|
|
(and (file-exists? p)
|
|
p)))
|
|
paths)
|
|
;; Can't find it, so just use executable's dir:
|
|
(build-path exe-dir dll)))))
|
|
|
|
(define (copy-framework name 3m? lib-dir)
|
|
(let* ([fw-name (format "~a.framework" name)]
|
|
[sub-dir (build-path fw-name "Versions"
|
|
(if 3m?
|
|
(format "~a_3m" (version))
|
|
(version)))])
|
|
(make-directory* (build-path lib-dir sub-dir))
|
|
(let* ([fw-name (build-path sub-dir (format "~a" name))]
|
|
[dll-dir (find-framework fw-name)])
|
|
(copy-file* (build-path dll-dir fw-name)
|
|
(build-path lib-dir fw-name))
|
|
(let ([rsrc-src (build-path dll-dir sub-dir "Resources")])
|
|
(when (directory-exists? rsrc-src)
|
|
(copy-directory/files*
|
|
rsrc-src
|
|
(build-path lib-dir sub-dir "Resources")))))))
|
|
|
|
(define (find-framework fw-name)
|
|
(let ([dll-dir (find-dll-dir)])
|
|
(or dll-dir
|
|
(ormap (lambda (p)
|
|
(let ([f (build-path p fw-name)])
|
|
(and (file-exists? f)
|
|
p)))
|
|
'("/System/Library/Frameworks"
|
|
"/Library/Frameworks"
|
|
"~/Library/Frameworks"))
|
|
;; Can't find it, so just use relative path:
|
|
(build-path 'same))))
|
|
|
|
;; cache:
|
|
(define avail-lib-files #f)
|
|
|
|
(define (copy-shared-lib name lib-dir)
|
|
(unless avail-lib-files
|
|
(set! avail-lib-files (directory-list (find-dll-dir))))
|
|
(let* ([rx (byte-regexp (string->bytes/latin-1
|
|
(format "lib~a-~a.*[.](?:so|dylib)$" name (version))))]
|
|
[files (filter (lambda (f)
|
|
(regexp-match rx (path->bytes f)))
|
|
avail-lib-files)])
|
|
(when (null? files)
|
|
(error 'copy-shared-lib "cannot find shared library for ~a"
|
|
name))
|
|
(unless (null? (cdr files))
|
|
(error 'copy-shared-lib
|
|
"found multiple shared-library candidates for ~a: ~e"
|
|
name
|
|
files))
|
|
(copy-file* (build-path (find-dll-dir) (car files))
|
|
(build-path lib-dir (car files)))))
|
|
|
|
(define (patch-binaries binaries types)
|
|
(case (system-type)
|
|
[(windows)
|
|
(for-each (lambda (b)
|
|
(update-dll-dir b "lib"))
|
|
binaries)]
|
|
[(macosx)
|
|
(if (and (= 1 (length types))
|
|
(memq (car types) '(gracketcgc gracket3m)))
|
|
;; Special case for single GRacket app:
|
|
(update-framework-path "@executable_path/../Frameworks/"
|
|
(car binaries)
|
|
#t)
|
|
;; General case:
|
|
(for-each (lambda (b type)
|
|
(update-framework-path (if (memq type '(racketcgc racket3m))
|
|
"@executable_path/../lib/"
|
|
"@executable_path/../../../lib/" )
|
|
b
|
|
(memq type '(gracketcgc gracket3m))))
|
|
binaries types))]
|
|
[(unix)
|
|
(for-each (lambda (b type)
|
|
(patch-stub-exe-paths b
|
|
(build-path
|
|
"../lib/plt"
|
|
(format "~a-~a" type (version)))
|
|
(and (shared-libraries?)
|
|
"../lib")))
|
|
binaries
|
|
types)]))
|
|
|
|
(define (patch-stub-exe-paths b exe shared-lib-dir)
|
|
;; Adjust paths to executable and DLL that is embedded in the executable
|
|
(let-values ([(config-pos start end prog-len dll-len rest)
|
|
(with-input-from-file b
|
|
(lambda ()
|
|
(let* ([i (current-input-port)]
|
|
[m (regexp-match-positions #rx#"cOnFiG:" i)])
|
|
(unless m
|
|
(error 'patch-stub-exe-paths
|
|
"cannot find config info"))
|
|
(read-byte i)
|
|
(read-one-int i) ; start of decls
|
|
(read-one-int i) ; start of program
|
|
(let ([start (read-one-int i)] ; start of data
|
|
[end (read-one-int i)]) ; end of data
|
|
(file-position i start)
|
|
(let ([prog-len (next-bytes-length i)]
|
|
[dll-len (next-bytes-length i)])
|
|
(values (+ (cdar m) 1) ; position after "cOnFiG:[" tag
|
|
start
|
|
end
|
|
prog-len
|
|
dll-len
|
|
(read-bytes (- (- end start) prog-len dll-len))))))))])
|
|
(let ([exe-bytes (path->bytes (to-path exe))]
|
|
[shared-lib-bytes (if shared-lib-dir
|
|
(path->bytes (to-path shared-lib-dir))
|
|
#"")])
|
|
(let ([delta (- (+ prog-len dll-len)
|
|
(add1 (bytes-length exe-bytes))
|
|
(add1 (bytes-length shared-lib-bytes)))])
|
|
(with-output-to-file b
|
|
#:exists 'update
|
|
(lambda ()
|
|
(let ([o (current-output-port)])
|
|
(file-position o (+ config-pos 12)) ; update the end of the program data
|
|
(write-one-int (- end delta) o)
|
|
(flush-output o)
|
|
(file-position o start)
|
|
(write-bytes exe-bytes o)
|
|
(write-bytes #"\0" o)
|
|
(write-bytes shared-lib-bytes o)
|
|
(write-bytes #"\0" o)
|
|
(write-bytes rest o)
|
|
(flush-output o))))))))
|
|
|
|
(define (copy-and-patch-binaries copy? magic
|
|
extract-src construct-dest transform-entry
|
|
init-counter inc-counter
|
|
orig-binaries binaries types sub-dirs
|
|
exts-dir relative-exts-dir
|
|
relative->binary-relative)
|
|
(let loop ([orig-binaries orig-binaries]
|
|
[binaries binaries]
|
|
[types types]
|
|
[sub-dirs sub-dirs]
|
|
[counter init-counter])
|
|
(unless (null? binaries)
|
|
(let-values ([(exts start-pos end-pos)
|
|
(with-input-from-file (car binaries)
|
|
(lambda ()
|
|
(let* ([i (current-input-port)]
|
|
[m (regexp-match-positions magic i)])
|
|
(if m
|
|
;; Read table:
|
|
(begin
|
|
(file-position i (cdar m))
|
|
(let ([l (read i)])
|
|
(values (cadr l) (cdar m) (file-position i))))
|
|
;; No table:
|
|
(values null #f #f)))))])
|
|
(if (null? exts)
|
|
(loop (cdr orig-binaries) (cdr binaries) (cdr types) (cdr sub-dirs) counter)
|
|
(let-values ([(new-exts counter)
|
|
;; Copy over the extensions for this binary, generating a separate path
|
|
;; for each executable
|
|
(let loop ([exts exts][counter counter])
|
|
(cond
|
|
[(null? exts) (values null counter)]
|
|
[(and (pair? (car (car exts)))
|
|
(pair? (cdar (car exts)))
|
|
(eq? 'module (cadar (car exts))))
|
|
(let-values ([(rest-exts counter)
|
|
(loop (cdr exts) counter)])
|
|
(values (cons (car exts) rest-exts) counter))]
|
|
[else
|
|
(let* ([src (extract-src (car exts) (car orig-binaries))]
|
|
[dest (construct-dest src)]
|
|
[sub (format "e~a" counter)])
|
|
(when (and src copy?)
|
|
; Make dest and copy
|
|
(make-directory* (build-path exts-dir sub (or (path-only dest) 'same)))
|
|
(let ([f (build-path exts-dir sub dest)])
|
|
(when (or (file-exists? f)
|
|
(directory-exists? f)
|
|
(link-exists? f))
|
|
(delete-directory/files f))
|
|
(copy-directory/files src f)))
|
|
;; Generate the new extension entry for the table, and combine with
|
|
;; recur result for the rest:
|
|
(let-values ([(rest-exts counter)
|
|
(loop (cdr exts) (inc-counter counter))])
|
|
(values (if src
|
|
(cons (transform-entry
|
|
(path->bytes
|
|
(relative->binary-relative (car sub-dirs)
|
|
(car types)
|
|
(build-path relative-exts-dir sub dest)))
|
|
(car exts))
|
|
rest-exts)
|
|
(cons (car exts)
|
|
rest-exts))
|
|
counter)))]))])
|
|
(when copy?
|
|
;; Update the binary with the new paths
|
|
(let* ([str (string->bytes/utf-8 (format "~s" new-exts))]
|
|
[extra-space 7] ; = "(quote" plus ")"
|
|
[delta (- (- end-pos start-pos) (bytes-length str) extra-space)])
|
|
(when (negative? delta)
|
|
(error 'copy-and-patch-binaries
|
|
"not enough room in executable for revised ~s table"
|
|
magic))
|
|
(with-output-to-file (car binaries)
|
|
#:exists 'update
|
|
(lambda ()
|
|
(let ([o (current-output-port)])
|
|
(file-position o start-pos)
|
|
(write-bytes #"(quote" o)
|
|
(write-bytes str o)
|
|
;; Add space before final closing paren. This preserves space in case the
|
|
;; genereated binary is input for a future distribution build.
|
|
(write-bytes (make-bytes delta (char->integer #\space)) o)
|
|
(write-bytes #")" o))))))
|
|
(loop (cdr orig-binaries) (cdr binaries) (cdr types) (cdr sub-dirs) counter)))))))
|
|
|
|
(define (copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs
|
|
exts-dir relative-exts-dir
|
|
relative->binary-relative)
|
|
(copy-and-patch-binaries #t #rx#"eXtEnSiOn-modules[)]"
|
|
;; extract-src:
|
|
(lambda (ext orig-binary)
|
|
(path->complete-path
|
|
(bytes->path (car ext))
|
|
(let-values ([(base name dir?)
|
|
(split-path (path->complete-path orig-binary
|
|
(current-directory)))])
|
|
base)))
|
|
;; construct-dest:
|
|
(lambda (src)
|
|
(let-values ([(base name dir?) (split-path src)])
|
|
name))
|
|
;; transform-entry
|
|
(lambda (new-path ext)
|
|
(list new-path (cadr ext)))
|
|
0 add1 ; <- counter
|
|
orig-binaries binaries types sub-dirs
|
|
exts-dir relative-exts-dir
|
|
relative->binary-relative))
|
|
|
|
(define (copy-runtime-files-and-patch-binaries orig-binaries binaries types sub-dirs
|
|
exts-dir relative-exts-dir
|
|
relative->binary-relative)
|
|
(let ([paths null])
|
|
;; Pass 1: collect all the paths
|
|
(copy-and-patch-binaries #f #rx#"rUnTiMe-paths[)]"
|
|
;; extract-src:
|
|
(lambda (rt orig-binary)
|
|
(and (cadr rt)
|
|
(bytes? (cadr rt))
|
|
(bytes->path (cadr rt))))
|
|
;; construct-dest:
|
|
(lambda (src)
|
|
(when src
|
|
(set! paths (cons src paths)))
|
|
"dummy")
|
|
;; transform-entry
|
|
(lambda (new-path ext) ext)
|
|
"rt" values ; <- counter
|
|
orig-binaries binaries types sub-dirs
|
|
exts-dir relative-exts-dir
|
|
relative->binary-relative)
|
|
(unless (null? paths)
|
|
;; Determine the shared path prefix:
|
|
(let* ([root-table (make-hash)]
|
|
[root->path-element (lambda (root)
|
|
(hash-ref root-table
|
|
root
|
|
(lambda ()
|
|
(let ([v (format "r~a" (hash-count root-table))])
|
|
(hash-set! root-table root v)
|
|
v))))]
|
|
[explode (lambda (src)
|
|
(reverse
|
|
(let loop ([src src])
|
|
(let-values ([(base name dir?) (split-path src)])
|
|
(if base
|
|
(cons name (loop base))
|
|
(list (root->path-element name)))))))]
|
|
;; In reverse order, so we can pick off the paths
|
|
;; in the second pass:
|
|
[exploded (reverse (map explode paths))]
|
|
[max-len (apply max 0 (map length exploded))]
|
|
[common-len (let loop ([cnt 0])
|
|
(cond
|
|
[((add1 cnt) . = . max-len) cnt]
|
|
[(andmap (let ([i (list-ref (car exploded) cnt)])
|
|
(lambda (e)
|
|
(equal? (list-ref e cnt) i)))
|
|
exploded)
|
|
(loop (add1 cnt))]
|
|
[else cnt]))])
|
|
|
|
|
|
;; Pass 2: change all the paths
|
|
(copy-and-patch-binaries #t #rx#"rUnTiMe-paths[)]"
|
|
;; extract-src:
|
|
(lambda (rt orig-binary)
|
|
(and (cadr rt)
|
|
(bytes->path (cadr rt))))
|
|
;; construct-dest:
|
|
(lambda (src)
|
|
(and src
|
|
(begin0
|
|
(apply build-path (list-tail (car exploded) common-len))
|
|
(set! exploded (cdr exploded)))))
|
|
;; transform-entry
|
|
(lambda (new-path ext)
|
|
(cons (car ext) (list new-path)))
|
|
"rt" values ; <- counter
|
|
orig-binaries binaries types sub-dirs
|
|
exts-dir relative-exts-dir
|
|
relative->binary-relative)))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Utilities
|
|
|
|
(define (shared-libraries?)
|
|
(eq? 'shared (system-type 'link)))
|
|
|
|
(define (to-path s)
|
|
(if (string? s)
|
|
(string->path s)
|
|
s))
|
|
|
|
(define (get-binary-type b)
|
|
;; Since this is called first, we also check that the executable
|
|
;; is a stub binary for Unix.
|
|
(with-input-from-file (app-to-file b)
|
|
(lambda ()
|
|
(let ([m (regexp-match #rx#"bINARy tYPe:(e?)(.)(.)(.)" (current-input-port))])
|
|
(if m
|
|
(begin
|
|
(when (eq? 'unix (system-type))
|
|
(unless (equal? (cadr m) #"e")
|
|
(error 'assemble-distribution
|
|
"file is an original PLT executable, not a stub binary: ~e"
|
|
b)))
|
|
(let ([3m? (equal? (list-ref m 4) #"3")])
|
|
(if (equal? (caddr m) #"r")
|
|
(if 3m?
|
|
'gracket3m
|
|
'gracketcgc)
|
|
(if 3m?
|
|
'racket3m
|
|
'racketcgc))))
|
|
(error 'assemble-distribution
|
|
"file is not a PLT executable: ~e"
|
|
b))))))
|
|
|
|
(define (write-one-int n out)
|
|
(write-bytes (integer->integer-bytes n 4 #t #f) out))
|
|
|
|
(define (read-one-int in)
|
|
(integer-bytes->integer (read-bytes 4 in) #t #f))
|
|
|
|
(define (next-bytes-length in)
|
|
(let ([m (regexp-match-positions #rx#"\0" in)])
|
|
(cdar m)))
|
|
|
|
(define (copy-file* src dest)
|
|
(when (or (file-exists? dest)
|
|
(link-exists? dest))
|
|
(delete-file dest))
|
|
(copy-file src dest)
|
|
(let ([t (file-or-directory-modify-seconds src)])
|
|
(file-or-directory-modify-seconds dest t)))
|
|
|
|
(define (copy-directory/files* src dest)
|
|
(cond
|
|
[(directory-exists? src)
|
|
(unless (directory-exists? dest)
|
|
(make-directory dest))
|
|
(for-each (lambda (f)
|
|
(copy-directory/files* (build-path src f)
|
|
(build-path dest f)))
|
|
(directory-list src))]
|
|
[else
|
|
(copy-file* src dest)]))
|
|
|
|
(define (copy-app src dest)
|
|
(when (or (file-exists? dest)
|
|
(directory-exists? dest)
|
|
(link-exists? dest))
|
|
(delete-directory/files dest))
|
|
(copy-directory/files src dest))
|
|
|
|
(define (app-to-file b)
|
|
(if (and (eq? 'macosx (system-type))
|
|
(regexp-match #rx#"[.][aA][pP][pP]$"
|
|
(path->bytes (if (string? b)
|
|
(string->path b)
|
|
b))))
|
|
(let ([no-app
|
|
(let-values ([(base name dir?) (split-path b)])
|
|
(path-replace-suffix name #""))])
|
|
(build-path b "Contents" "MacOS" no-app))
|
|
b)))
|