From ce7c0d62c3ab81f5e8ee0cf0ed70fefb98f363b5 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 24 Aug 2011 19:37:16 -0600
Subject: [PATCH] if only a Unix root is shared, don't make a path relative

---
 collects/racket/path.rkt                   |  9 +++++++--
 collects/scribblings/reference/paths.scrbl | 14 ++++++++++----
 collects/setup/link.rkt                    |  3 ++-
 collects/tests/racket/pathlib.rktl         |  9 +++++++++
 4 files changed, 28 insertions(+), 7 deletions(-)

diff --git a/collects/racket/path.rkt b/collects/racket/path.rkt
index ce33f3ee2c..d30a9ddc7a 100644
--- a/collects/racket/path.rkt
+++ b/collects/racket/path.rkt
@@ -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))]
diff --git a/collects/scribblings/reference/paths.scrbl b/collects/scribblings/reference/paths.scrbl
index cccfcc356d..08e044a7c1 100644
--- a/collects/scribblings/reference/paths.scrbl
+++ b/collects/scribblings/reference/paths.scrbl
@@ -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?)
diff --git a/collects/setup/link.rkt b/collects/setup/link.rkt
index f03a300b44..0de6e8d37a 100644
--- a/collects/setup/link.rkt
+++ b/collects/setup/link.rkt
@@ -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
diff --git a/collects/tests/racket/pathlib.rktl b/collects/tests/racket/pathlib.rktl
index a244661f01..8f4ff78490 100644
--- a/collects/tests/racket/pathlib.rktl
+++ b/collects/tests/racket/pathlib.rktl
@@ -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))
 
 ;; ----------------------------------------