rel-path building needs case-normalized paths

svn: r2839
This commit is contained in:
Matthew Flatt 2006-04-28 17:26:00 +00:00
parent a377f0cc46
commit 7e16058111
2 changed files with 11 additions and 6 deletions

View File

@ -121,9 +121,11 @@
(define (relativize exec-name dest adjust)
(let ([p (find-relative-path
(let-values ([(dir name dir?) (split-path (normalize-path dest))])
(let-values ([(dir name dir?) (split-path
(normal-case-path
(normalize-path dest)))])
dir)
(normalize-path exec-name))])
(normal-case-path (normalize-path exec-name)))])
(if (relative-path? p)
(adjust p)
p)))

View File

@ -236,6 +236,9 @@
(let ([s (if (path? s) (path->string s) s)])
(regexp-replace* #rx"[\"$`]" s "\\\\&")))
(define (normalize+explode-path p)
(explode-path (normal-case-path (normalize-path p))))
(define (relativize bindir-explode dest-explode)
(let loop ([b bindir-explode] [d dest-explode])
(if (and (pair? b) (equal? (car b) (car d)))
@ -252,8 +255,8 @@
(file-exists? (build-path "/bin" exe))))
(let* ([has-readlink? (and (not (eq? 'macosx (system-type)))
(has-exe? "readlink"))]
[dest-explode (explode-path (normalize-path dest))]
[bindir-explode (explode-path (normalize-path bindir))])
[dest-explode (normalize+explode-path dest)]
[bindir-explode (normalize+explode-path bindir)])
(if (and (has-exe? "dirname") (has-exe? "basename")
(or has-readlink? (and (has-exe? "ls") (has-exe? "sed")))
(equal? (car dest-explode) (car bindir-explode)))
@ -385,8 +388,8 @@
(let* ([exedir (bytes-append
(path->bytes (if (let ([m (assq 'relative? aux)])
(and m (cdr m)))
(or (relativize (explode-path plthome)
(explode-path dest))
(or (relativize (normalize+explode-path plthome)
(normalize+explode-path dest))
(build-path 'same))
plthome))
;; null character marks end of executable directory