From a129450e9b56cee8e307fc5c320105fe00ba45b7 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Wed, 6 Nov 2013 22:39:31 +0400 Subject: [PATCH] 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. --- src/code/win32-pathname.lisp | 21 +++++++++++++++------ tests/pathnames.impure.lisp | 32 ++++++++++++++++---------------- 2 files changed, 31 insertions(+), 22 deletions(-) diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index 169f384..72bb09d 100644 --- 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 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -325,7 +325,7 @@ ;;; 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))))) ;;; BUG 330: "PARSE-NAMESTRING should accept namestrings as the @@ -398,9 +398,9 @@ ;;; 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))))) ;;; 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:**;*\"")))) ;;; 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 -- 1.7.10.4