suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

if only a Unix root is shared, don't make a path relative

Browse Source
This commit is contained in:
Matthew Flatt 2011-08-24 19:37:16 -06:00
parent ec29a2d85c
commit ce7c0d62c3
4 changed files with 28 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/racket/path.rkt
View File

@ -132,10 +132,15 @@
(do-explode-path 'explode-path orig-path #f))
;; Arguments must be in simple form
(define (find-relative-path directory filename)
(define (find-relative-path directory filename #:more-than-root? [more-than-root? #f])
(let ([dir (do-explode-path 'find-relative-path directory #t)]
[file (do-explode-path 'find-relative-path filename #t)])
(if (equal? (car dir) (car file))
(if (and (equal? (car dir) (car file))
(or (not more-than-root?)
(not (eq? 'unix (path-convention-type directory)))
(null? (cdr dir))
(null? (cdr file))
(equal? (cadr dir) (cadr file))))
(let loop ([dir (cdr dir)]
[file (cdr file)])
(cond [(null? dir) (if (null? file) filename (apply build-path file))]

14
collects/scribblings/reference/paths.scrbl
View File

@ -529,14 +529,20 @@ syntactically a directory (see @racket[split-path]) or if the path has
no extension, @racket[#f] is returned.}
@defproc[(find-relative-path [base (or/c path-string? path-for-some-system?)]
[path (or/c path-string? path-for-some-system?)])
[path (or/c path-string? path-for-some-system?)]
[#:more-than-root? more-than-root? any/c #f])
path-for-some-system?]{
Finds a relative pathname with respect to @racket[base] that names the
same file or directory as @racket[path]. Both @racket[base] and
@racket[path] must be simplified in the sense of @racket[simple-form-path]. If
@racket[path] is not a proper subpath of @racket[base] (i.e., a
subpath that is strictly longer), @racket[path] is returned.}
@racket[path] must be simplified in the sense of
@racket[simple-form-path]. If @racket[path] shares no subpath in
common with @racket[base], @racket[path] is returned.
If @racket[more-than-root?] is true, if @racket[base] and
@racket[path] share only a Unix root in common, and if neither
@racket[base] nor @racket[path] is just a root path, then
@racket[path] is returned.}
@defproc[(normalize-path [path path-string?]
[wrt (and/c path-string? complete-path?)

3
collects/setup/link.rkt
View File

@ -110,7 +110,8 @@
(let* ([dp (and d
(find-relative-path file-dir
(simplify-path
(path->complete-path d))))]
(path->complete-path d))
#:more-than-root? #t))]
[a-name (if root?
'root
(and d

9
collects/tests/racket/pathlib.rktl
View File

@ -45,6 +45,15 @@
(test (build-path 'up 'up "b" "a") find-relative-path (path->complete-path "c/b") (path->complete-path "b/a"))
(test (bytes->path #"a" 'unix) find-relative-path (bytes->path #"/r/b" 'unix) (bytes->path #"/r/b/a" 'unix))
(test (bytes->path #"a" 'windows) find-relative-path (bytes->path #"c:/r/b" 'windows) (bytes->path #"c:/r/b/a" 'windows))
(test (bytes->path #"d:/r/b/a" 'windows) find-relative-path (bytes->path #"c:/r/b" 'windows) (bytes->path #"d:/r/b/a" 'windows))
(test (bytes->path #"../b/a" 'unix) find-relative-path (bytes->path #"/r/c" 'unix) (bytes->path #"/r/b/a" 'unix))
(test (bytes->path #"../../q/b/a" 'unix) find-relative-path (bytes->path #"/r/c" 'unix) (bytes->path #"/q/b/a" 'unix))
(test (bytes->path #"/q/b/a" 'unix) 'find-relative-path (find-relative-path (bytes->path #"/r/c" 'unix) (bytes->path #"/q/b/a" 'unix)
#:more-than-root? #t))
(test (bytes->path #"q/b/a" 'unix) 'find-relative-path (find-relative-path (bytes->path #"/" 'unix) (bytes->path #"/q/b/a" 'unix)
#:more-than-root? #t))
(test (bytes->path #"../.." 'unix) 'find-relative-path (find-relative-path (bytes->path #"/r/c" 'unix) (bytes->path #"/" 'unix)
#:more-than-root? #t))
;; ----------------------------------------