When DESTDIR ends with a '/', dirs.ss spits out directories with '//'
in them, which caused problems with main-collects not identifying paths as paths in the plt tree. The solution is to use expand-path for these things, which normalizses multiple slashes to a single one. While I'm at it, I did the same for dirs.ss, so it produces more consistent paths for code that might want to rely on it. (Also did some reformatting.) svn: r4477
This commit is contained in:
Eli Barzilay
parent
b8c6f3fa73
commit
c1cc293cd5
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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*))
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user