Index: collects/setup/dirs.ss =================================================================== --- collects/setup/dirs.ss (revision 4476) +++ collects/setup/dirs.ss (revision 4477) @@ -1,42 +1,49 @@ (module dirs mzscheme (require (prefix config: (lib "config.ss" "config")) - (lib "winutf16.ss" "compiler" "private") - (lib "mach-o.ss" "compiler" "private")) + (lib "winutf16.ss" "compiler" "private") + (lib "mach-o.ss" "compiler" "private")) (provide (rename config:absolute-installation? absolute-installation?)) + ;; path normalization is not really necessary by any existing code, + ;; but there might be applications that rely on these paths, so it's + ;; best to do some minor normalization. This is similar to what + ;; "main-collects.ss" does. Again, this makes mzscheme expand paths + ;; that begin with `~'. + (define (system-path* what) + (expand-path (simplify-path (find-system-path what) #f))) + ;; ---------------------------------------- ;; "collects" (define main-collects-dir (delay - (let ([d (find-system-path 'collects-dir)]) - (cond - [(complete-path? d) d] - [(absolute-path? d) - ;; This happens only under Windows; add a drive - ;; specification to make the path complete - (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)]) - (path->complete-path d base)))] - [else - ;; Relative to executable... - (parameterize ([current-directory (find-system-path 'orig-dir)]) - (let ([p (or (find-executable-path (find-system-path 'exec-file) d #t) - ;; If we get here, then we can't find the directory - #f)]) - (and p - (simplify-path p))))])))) + (let ([d (system-path* 'collects-dir)]) + (cond + [(complete-path? d) d] + [(absolute-path? d) + ;; This happens only under Windows; add a drive + ;; specification to make the path complete + (let ([exec (path->complete-path + (find-executable-path (system-path* 'exec-file)) + (system-path* 'orig-dir))]) + (let-values ([(base name dir?) (split-path exec)]) + (path->complete-path d base)))] + [else + ;; Relative to executable... + (parameterize ([current-directory (system-path* 'orig-dir)]) + (let ([p (or (find-executable-path (system-path* 'exec-file) d #t) + ;; If we get here, then we can't find the directory + #f)]) + (and p (simplify-path p))))])))) (provide find-collects-dir - find-user-collects-dir - get-collects-search-dirs) + find-user-collects-dir + get-collects-search-dirs) (define (find-collects-dir) (force main-collects-dir)) (define user-collects-dir - (delay (build-path (find-system-path 'addon-dir) (version) "collects"))) + (delay (build-path (system-path* 'addon-dir) (version) "collects"))) (define (find-user-collects-dir) (force user-collects-dir)) (define (get-collects-search-dirs) @@ -50,51 +57,47 @@ (define (combine-search l default) ;; Replace #f in list with default path: (if l - (let loop ([l l]) - (cond - [(null? l) null] - [(not (car l)) (append default (loop (cdr l)))] - [else (cons (car l) (loop (cdr l)))])) - default)) + (let loop ([l l]) + (cond + [(null? l) null] + [(not (car l)) (append default (loop (cdr l)))] + [else (cons (car l) (loop (cdr l)))])) + default)) (define (cons-user u r) - (if (use-user-specific-search-paths) - (cons u r) - r)) + (if (use-user-specific-search-paths) (cons u r) r)) (define-syntax define-finder (syntax-rules () [(_ provide config:id id user-id config:search-id search-id default) (begin - (define-finder provide config:id id user-id default) - (provide search-id) - (define (search-id) - (combine-search (force config:search-id) - (cons-user (user-id) (single (id))))))] - [(_ provide config:id id user-id config:search-id search-id extra-search-dir default) + (define-finder provide config:id id user-id default) + (provide search-id) + (define (search-id) + (combine-search (force config:search-id) + (cons-user (user-id) (single (id))))))] + [(_ provide config:id id user-id config:search-id search-id + extra-search-dir default) (begin - (define-finder provide config:id id user-id default) - (provide search-id) - (define (search-id) - (combine-search (force config:search-id) - (extra (extra-search-dir) - (cons-user (user-id) (single (id)))))))] + (define-finder provide config:id id user-id default) + (provide search-id) + (define (search-id) + (combine-search (force config:search-id) + (extra (extra-search-dir) + (cons-user (user-id) (single (id)))))))] [(_ provide config:id id user-id default) (begin - (provide id user-id) - (define dir - (delay - (or (force config:id) - (let ([p (find-collects-dir)]) - (and p - (simplify-path (build-path p - 'up - default))))))) - (define (id) - (force dir)) - (define user-dir - (delay (build-path (find-system-path 'addon-dir) (version) default))) - (define (user-id) - (force user-dir)))])) + (provide id user-id) + (define dir + (delay + (or (force config:id) + (let ([p (find-collects-dir)]) + (and p (simplify-path (build-path p 'up default))))))) + (define (id) + (force dir)) + (define user-dir + (delay (build-path (system-path* 'addon-dir) (version) default))) + (define (user-id) + (force user-dir)))])) (define-syntax no-provide (syntax-rules () [(_ . rest) (begin)])) @@ -104,8 +107,8 @@ (define delayed-#f (delay #f)) (provide find-doc-dir - find-user-doc-dir - get-doc-search-dirs) + find-user-doc-dir + get-doc-search-dirs) (define-finder no-provide config:doc-dir find-doc-dir @@ -116,9 +119,9 @@ ;; For now, include "doc" pseudo-collections in search path: (define (get-doc-search-dirs) (combine-search (force config:doc-search-dirs) - (append (get-new-doc-search-dirs) - (map (lambda (p) (build-path p "doc")) - (current-library-collection-paths))))) + (append (get-new-doc-search-dirs) + (map (lambda (p) (build-path p "doc")) + (current-library-collection-paths))))) ;; ---------------------------------------- ;; "include" @@ -145,14 +148,14 @@ ;; ---------------------------------------- ;; Executables - (define-finder provide + (define-finder provide config:bin-dir - find-console-bin-dir + find-console-bin-dir find-user-console-bin-dir (case (system-type) [(windows) 'same] [(macosx unix) "bin"])) - + (define-finder provide config:bin-dir find-gui-bin-dir @@ -163,64 +166,66 @@ ;; ---------------------------------------- ;; DLLs - + (provide find-dll-dir) (define dll-dir - (delay (case (system-type) - [(windows) - ;; Extract "lib" location from binary: - (let ([exe (parameterize ([current-directory (find-system-path 'orig-dir)]) - (find-executable-path (find-system-path 'exec-file)))]) - (with-input-from-file exe - (lambda () - (let ([m (regexp-match (byte-regexp - (bytes-append - (bytes->utf-16-bytes #"dLl dIRECTORy:") - #"((?:..)*?)\0\0")) - (current-input-port))]) - (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 - #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 - (if (eq? 'shared (system-type 'link)) - (or (force config:dll-dir) - (find-lib-dir)) - #f)]))) + (delay + (case (system-type) + [(windows) + ;; Extract "lib" location from binary: + (let ([exe (parameterize ([current-directory (system-path* 'orig-dir)]) + (find-executable-path (system-path* 'exec-file)))]) + (with-input-from-file exe + (lambda () + (let ([m (regexp-match (byte-regexp + (bytes-append + (bytes->utf-16-bytes #"dLl dIRECTORy:") + #"((?:..)*?)\0\0")) + (current-input-port))]) + (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 + #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 (system-path* 'orig-dir)]) + (let loop ([p (find-executable-path + (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)))] + [rel (get/set-dylib-path exe "PLT_M[rz]" #f)]) + (cond + [(not rel) #f] ; no framework reference found!? + [(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))))) + (system-path* 'orig-dir))))))] + [else (find-lib-dir)]))] + [else + (if (eq? 'shared (system-type 'link)) + (or (force config:dll-dir) (find-lib-dir)) + #f)]))) (define (find-dll-dir) (force dll-dir))) Index: collects/setup/main-collects.ss =================================================================== --- collects/setup/main-collects.ss (revision 4476) +++ collects/setup/main-collects.ss (revision 4477) @@ -1,16 +1,16 @@ (module main-collects mzscheme (require "dirs.ss") - + (provide path->main-collects-relative - main-collects-relative->path) - + main-collects-relative->path) + ;; Historical note: this module is based on the old "plthome.ss" ;; The `path->main-collects-relative' and ;; `main-collects-relative->path' functions are used to store paths ;; that are relative to the main "collects" directory, such as in ;; .dep files. This means that if the plt tree is moved, .dep files - ;; still work. It is generally fine if + ;; still work. It is generally fine if ;; `path->main-collects-relative' misses some usages, as long as it ;; works when we prepare a distribution tree. Otherwise, things ;; will continue to work fine and .dep files will just contain @@ -18,27 +18,25 @@ ;; either a pathname or a pair with a pathname in its cdr; the ;; `path->main-collects-relative' pathname will itself be a pair. + ;; we need to compare paths to find when something is in the plt + ;; tree -- this does some basic "normalization" that should work + ;; fine: getting rid of `.' and `..' (simplify-path) and collapsing + ;; `//' to `/' (expand-path). Using `expand-path' also expands `~' + ;; and `~user', but this should not be a problem in practice. (define (simplify-bytes-path bytes) - (path->bytes (simplify-path (bytes->path bytes)))) - + (path->bytes (expand-path (simplify-path (bytes->path bytes))))) + ;; on Windows, turn backslashes to forward slashes (define simplify-path* (if (eq? 'windows (system-type)) - (lambda (str) - (regexp-replace* #rx#"\\\\" (simplify-bytes-path str) #"/")) + (lambda (bytes) + (simplify-bytes-path (regexp-replace* #rx#"\\\\" bytes #"/"))) simplify-bytes-path)) - (define main-collects-dir-bytes - (delay (and (find-collects-dir) - (path->bytes (find-collects-dir))))) - (define main-collects-dir/ - (delay (and (force main-collects-dir-bytes) - (regexp-replace #rx#"/?$" - (simplify-path* (force main-collects-dir-bytes)) - #"/")))) - (define main-collects-dir/-len - (delay (and (force main-collects-dir/) - (bytes-length (force main-collects-dir/))))) + (delay (let ([dir (find-collects-dir)]) + (and dir (regexp-replace #rx#"/*$" + (simplify-path* (path->bytes dir)) + #"/"))))) (define (maybe-cdr-op fname f) (lambda (x) @@ -53,14 +51,15 @@ [else (error 'path->main-collects-relative "expecting a byte-string, got ~e" path)])] [path* (simplify-path* path)] - [mcd-len (force main-collects-dir/-len)]) + [main-collects-dir/ (force main-collects-dir/)] + [mcd-len (bytes-length main-collects-dir/)]) (cond [(and path* mcd-len (> (bytes-length path*) mcd-len) (equal? (subbytes path* 0 mcd-len) - (force main-collects-dir/))) + main-collects-dir/)) (cons 'collects (subbytes path* mcd-len))] - [(equal? path* (force main-collects-dir/)) (cons 'collects #"")] + [(equal? path* main-collects-dir/) (cons 'collects #"")] [else path]))) ;; main-collects-relative->path* : datum-containing-bytes-or-path -> path @@ -77,6 +76,8 @@ [(bytes? path) (bytes->path path)] [else path])) - (define path->main-collects-relative (maybe-cdr-op 'path->main-collects-relative path->main-collects-relative*)) - (define main-collects-relative->path (maybe-cdr-op 'main-collects-relative->path main-collects-relative->path*)) + (define path->main-collects-relative + (maybe-cdr-op 'path->main-collects-relative path->main-collects-relative*)) + (define main-collects-relative->path + (maybe-cdr-op 'main-collects-relative->path main-collects-relative->path*)) )