From: Stas Boukarev <stassats@gmail.com>
Date: Sun, 10 Nov 2013 15:59:35 +0000 (+0400)
Subject: Fix merging of ~/ pathnames.
X-Git-Url: http://repo.macrolet.net/gitweb/?p=sbcl.git;a=commitdiff_plain;h=772e2f4f22a7034fc6f9101d9f088163a0d32e77

Fix merging of ~/ pathnames.

Don't merge the device component if the resulting pathname starts with
:absolute :home. The expansion of ~ may contain it's own device,
causing problems, especially on Windows, where
(merge-pathnames "~/") => c:C:\Users\user.
---

diff --git a/NEWS b/NEWS
index 0605d50..898f465 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,7 @@ changes relative to sbcl-1.1.13:
   * bug fix: EQUALP now compares correctly structures with raw slots larger
     than a single word.
   * bug fix: contribs couldn't be built on Windows with MinGW.
+  * bug fix: Better pathname handling on Windows.
 
 changes in sbcl-1.1.13 relative to sbcl-1.1.12:
   * optimization: better distribution of SXHASH over small conses of related
diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 2d20434..80cd3f9 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -453,15 +453,21 @@ the operating system native pathname conventions."
              (diddle-case
               (and default-host pathname-host
                    (not (eq (host-customary-case default-host)
-                            (host-customary-case pathname-host))))))
+                            (host-customary-case pathname-host)))))
+             (directory (merge-directories (%pathname-directory pathname)
+                                           (%pathname-directory defaults)
+                                           diddle-case)))
         (%make-maybe-logical-pathname
          (or pathname-host default-host)
-         (or (%pathname-device pathname)
-             (maybe-diddle-case (%pathname-device defaults)
-                                diddle-case))
-         (merge-directories (%pathname-directory pathname)
-                            (%pathname-directory defaults)
-                            diddle-case)
+         (and ;; The device of ~/ shouldn't be merged,
+              ;; because the expansion may have a different device
+              (not (and (>= (length directory) 2)
+                        (eql (car directory) :absolute)
+                        (eql (cadr directory) :home)))
+              (or (%pathname-device pathname)
+                  (maybe-diddle-case (%pathname-device defaults)
+                                     diddle-case)))
+         directory
          (or (%pathname-name pathname)
              (maybe-diddle-case (%pathname-name defaults)
                                 diddle-case))
diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 0b06d6f..4361c3d 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -579,7 +579,9 @@
   ;; Not at the start of the first directory
   (assert (equal (native-namestring #p"foo/~/bar")
                  #-win32 "foo/~/bar"
-                 #+win32 "foo\\~\\bar")))
+                 #+win32 "foo\\~\\bar"))
+  (equal (native-namestring (merge-pathnames "~/"))
+         (native-namestring (user-homedir-pathname))))
 
 ;;; lp#673625
 (with-test (:name :pathname-escape-first-directory-component