From 772e2f4f22a7034fc6f9101d9f088163a0d32e77 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Sun, 10 Nov 2013 19:59:35 +0400 Subject: [PATCH] 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. --- NEWS | 1 + src/code/target-pathname.lisp | 20 +++++++++++++------- tests/pathnames.impure.lisp | 4 +++- 3 files changed, 17 insertions(+), 8 deletions(-) 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 -- 1.7.10.4