common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

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

Browse source 
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.
This commit is contained in:
Stas Boukarev 2013-11-06 22:39:31 +04:00
parent 9de65d498a
commit a129450e9b
2 changed files with 31 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
src/code/win32-pathname.lisp
View file

@ -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)))

32
tests/pathnames.impure.lisp
View file

@ -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