Fix equality between #p"~" and (user-homedir-pathname) on Win32.

Don't use user-homedir-namestring on the windows version of
native-namestring, since the home directory can be specified as
C:/User/user, use (native-namestring (user-homedir-pathname)), which
will get C:\\User\\user\\ instead, making (native-namestring "~/") and
(native-namestring (user-homedir-pathname)) equal.

diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp
index 169f384..72bb09d 100644 (file)
--- a/src/code/win32-pathname.lisp
+++ b/src/code/win32-pathname.lisp
@@ -291,17 +291,26 @@
          (ecase (pop directory)
            (:absolute
             (let ((next (pop directory)))
+              ;; Don't use USER-HOMEDIR-NAMESTRING, since
+              ;; it can be specified as C:/User/user
+              ;; and (native-namestring (user-homedir-pathname))
+              ;; will be not equal to it, because it's parsed first.
               (cond ((eq :home next)
-                     (write-string (user-homedir-namestring) s))
+                     (write-string (native-namestring (user-homedir-pathname))
+                                   s))
                     ((and (consp next) (eq :home (car next)))
-                     (let ((where (user-homedir-namestring (second next))))
+                     (let ((where (user-homedir-pathname (second next))))
                        (if where
-                           (write-string where s)
+                           (write-string (native-namestring where) s)
                            (error "User homedir unknown for: ~S"
                                   (second next)))))
+                    ;; namestring of user-homedir-pathname already has
+                    ;; // at the end
                     (next
-                     (push next directory)))
-              (write-char #\\ s)))
+                     (write-char #\\ s)
+                     (push next directory))
+                    (t
+                     (write-char #\\ s)))))
            (:relative)))
        (loop for (piece . subdirs) on directory
              do (typecase piece
@@ -324,7 +333,7 @@
                  (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
                (write-char #\. s)
                (write-string type-string s)))
-           (when type-present-p ;
+           (when type-present-p
              (error
               "type component without a name component in NATIVE-NAMESTRING: ~S"
               type)))

diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index f675a8e..0b06d6f 100644 (file)
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -325,7 +325,7 @@
 \f
 ;;; ensure print-read consistency (or print-not-readable-error) on
 ;;; pathnames:
-(with-test (:name :print/read-consistency :fails-on :win32)
+(with-test (:name :print/read-consistency)
   (let ((pathnames (list
                     (make-pathname :name "foo" :type "txt" :version :newest)
                     (make-pathname :name "foo" :type "txt" :version 1)
@@ -337,17 +337,17 @@
     (dolist (p pathnames)
       (print p)
       (handler-case
-         (let* ((*print-readably* t)
-                (new (read-from-string (format nil "~S" p))))
-           (unless (equal new p)
-             (let ((*print-readably* nil))
-               (error "oops: host:~S device:~S dir:~S version:~S~% ->~%~
+          (let* ((*print-readably* t)
+                 (new (read-from-string (format nil "~S" p))))
+            (unless (equal new p)
+              (let ((*print-readably* nil))
+                (error "oops: host:~S device:~S dir:~S version:~S~% ->~%~
                              host:~S device:~S dir:~S version:~S"
-                      (pathname-host p) (pathname-device p)
-                      (pathname-directory p) (pathname-version p)
-                      (pathname-host new) (pathname-device new)
-                      (pathname-directory new) (pathname-version new)))))
-       (print-not-readable ()
+                       (pathname-host p) (pathname-device p)
+                       (pathname-directory p) (pathname-version p)
+                       (pathname-host new) (pathname-device new)
+                       (pathname-directory new) (pathname-version new)))))
+        (print-not-readable ()
           nil)))))
 \f
 ;;; BUG 330: "PARSE-NAMESTRING should accept namestrings as the
@@ -398,9 +398,9 @@
 \f
 ;;; we got (truename "/") wrong for about 6 months.  Check that it's
 ;;; still right.
-(with-test (:name :root-truename :fails-on :win32)
+(with-test (:name :root-truename)
   (let ((pathname (truename "/")))
-    (assert (equalp pathname #p"/"))
+    (assert (equalp pathname (merge-pathnames #p"/")))
     (assert (equal (pathname-directory pathname) '(:absolute)))))
 \f
 ;;; we failed to unparse logical pathnames with :NAME :WILD :TYPE NIL.
@@ -412,7 +412,7 @@
     (assert (string= (write-to-string pathname :readably t) "#P\"SYS:**;*\""))))
 \f
 ;;; reported by James Y Knight on sbcl-devel 2006-05-17
-(with-test (:name :merge-back :fails-on :win32)
+(with-test (:name :merge-back)
   (let ((p1 (make-pathname :directory '(:relative "bar")))
         (p2 (make-pathname :directory '(:relative :back "foo"))))
     (assert (equal (merge-pathnames p1 p2)
@@ -567,7 +567,7 @@
       (ignore-errors (delete-file bar))
       (setf (logical-pathname-translations "SYS") translations))))
 
-(with-test (:name :tilde-expansion :fails-on :win32)
+(with-test (:name :tilde-expansion)
   (assert (equal '(:absolute :home "foo") (pathname-directory "~/foo/bar.txt")))
   (assert (equal '(:absolute (:home "jdoe") "quux") (pathname-directory "~jdoe/quux/")))
   (assert (equal "~/foo/x" (namestring (make-pathname :directory '(:absolute :home "foo")
@@ -600,7 +600,7 @@
   (let* ((x '("hint--if-you-are-having-trouble-deleting-this-test-directory"
               "use-the-7zip-file-manager"))
          (base (truename
-                (directory-namestring (or *load-pathname* *compile-pathname*))))
+                (directory-namestring (or *load-pathname* *compile-file-pathname*))))
          (shallow (make-pathname :directory `(:relative ,(car x))))
          (shallow (merge-pathnames shallow base))
          (deep (make-pathname