Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv30056/src/code
Modified Files:
filesys.lisp pathname.lisp target-pathname.lisp toplevel.lisp
unix-pathname.lisp unix.lisp win32-pathname.lisp
Log Message:
0.9.18.9: Pathname Love on Win32
* Namestring simplification (was UNIX-SIMPLIFY-PATHNAME) is now
function of the host. Shamelessly cargo-culted Win32 version from
the Unix version.
* Kludged %ENUMERATE-DIRECTORIES to work with :WILD-INFERIORS on
Win32.
* Fix UNPARSE-NATIVE-WIN32-NAMESTRING to handle #P"X:\\FOO" case
correctly. ("X:\\FOO", not "X:\\\\FOO")
* Missing NEWS entry for 0.9.18.8.
* Correct order of arguments to MERGE-PATHNAMES in SYSINIT-PATHNAME.
* Couple of WITH-TEST additions to test-suite.
Index: filesys.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/filesys.lisp,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -d -r1.62 -r1.63
--- filesys.lisp 6 Sep 2006 20:27:10 -0000 1.62
+++ filesys.lisp 26 Oct 2006 16:07:54 -0000 1.63
@@ -252,6 +252,8 @@
follow-links nodes function
&aux (host (pathname-host pathname)))
(declare (simple-string head))
+ #!+win32
+ (setf follow-links nil)
(macrolet ((unix-xstat (name)
`(if follow-links
(sb!unix:unix-stat ,name)
@@ -302,6 +304,8 @@
sb!unix:s-ifdir))
(unless (dolist (dir nodes nil)
(when (and (eql (car dir) dev)
+ #!+win32 ;; KLUDGE
+ (not (zerop ino))
(eql (cdr dir) ino))
(return t)))
(let ((nodes (cons (cons dev ino) nodes))
@@ -479,11 +483,11 @@
(defun truename (pathname)
#!+sb-doc
"Return the pathname for the actual file described by PATHNAME.
- An error of type FILE-ERROR is signalled if no such file exists,
- or the pathname is wild.
+An error of type FILE-ERROR is signalled if no such file exists, or the
+pathname is wild.
- Under Unix, the TRUENAME of a broken symlink is considered to be
- the name of the broken symlink itself."
+Under Unix, the TRUENAME of a broken symlink is considered to be the name of
+the broken symlink itself."
(let ((result (probe-file pathname)))
(unless result
(error 'simple-file-error
@@ -495,7 +499,7 @@
(defun probe-file (pathname)
#!+sb-doc
"Return a pathname which is the truename of the file if it exists, or NIL
- otherwise. An error of type FILE-ERROR is signaled if pathname is wild."
+otherwise. An error of type FILE-ERROR is signaled if pathname is wild."
(let* ((defaulted-pathname (merge-pathnames
pathname
(sane-default-pathname-defaults)))
@@ -504,7 +508,9 @@
(let ((trueishname (sb!unix:unix-resolve-links namestring)))
(when trueishname
(let* ((*ignore-wildcards* t)
- (name (sb!unix:unix-simplify-pathname trueishname)))
+ (name (simplify-namestring
+ trueishname
+ (pathname-host defaulted-pathname))))
(if (eq (sb!unix:unix-file-kind name) :directory)
;; FIXME: this might work, but it's ugly.
(pathname (concatenate 'string name "/"))
@@ -811,8 +817,8 @@
;; grounds that the implementation should have repeatable
;; behavior when possible.
(sort (loop for name being each hash-key in truenames
- using (hash-value truename)
- collect (cons name truename))
+ using (hash-value truename)
+ collect (cons name truename))
#'string<
:key #'car))))
Index: pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/pathname.lisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- pathname.lisp 6 Sep 2006 20:27:10 -0000 1.19
+++ pathname.lisp 26 Oct 2006 16:07:54 -0000 1.20
@@ -26,6 +26,7 @@
(unparse-file (missing-arg) :type function)
(unparse-enough (missing-arg) :type function)
(unparse-directory-separator (missing-arg) :type simple-string)
+ (simplify-namestring (missing-arg) :type function)
(customary-case (missing-arg) :type (member :upper :lower)))
(def!method print-object ((host host) stream)
@@ -51,6 +52,7 @@
(unparse-file #'unparse-logical-file)
(unparse-enough #'unparse-enough-namestring)
(unparse-directory-separator ";")
+ (simplify-namestring #'identity)
(customary-case :upper)))
(name "" :type simple-string)
(translations nil :type list)
Index: target-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-pathname.lisp,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -d -r1.54 -r1.55
--- target-pathname.lisp 6 Sep 2006 20:27:10 -0000 1.54
+++ target-pathname.lisp 26 Oct 2006 16:07:54 -0000 1.55
@@ -27,6 +27,7 @@
(unparse-file #'unparse-unix-file)
(unparse-enough #'unparse-unix-enough)
(unparse-directory-separator "/")
+ (simplify-namestring #'simplify-unix-namestring)
(customary-case :lower))))
(defvar *unix-host* (make-unix-host))
(defun make-unix-host-load-form (host)
@@ -45,8 +46,9 @@
(unparse-file #'unparse-win32-file)
(unparse-enough #'unparse-win32-enough)
(unparse-directory-separator "\\")
+ (simplify-namestring #'simplify-win32-namestring)
(customary-case :upper))))
-(defvar *win32-host* (make-win32-host))
+(defparameter *win32-host* (make-win32-host))
(defun make-win32-host-load-form (host)
(declare (ignore host))
'*win32-host*)
@@ -525,12 +527,10 @@
(error "~S is not allowed as a directory component." piece))))
(results)))
(simple-string
- `(:absolute
- ,(maybe-diddle-case directory diddle-case)))
+ `(:absolute ,(maybe-diddle-case directory diddle-case)))
(string
`(:absolute
- ,(maybe-diddle-case (coerce directory 'simple-string)
- diddle-case)))))
+ ,(maybe-diddle-case (coerce directory 'simple-string) diddle-case)))))
(defun make-pathname (&key host
(device nil devp)
@@ -858,7 +858,8 @@
(let* ((end (%check-vector-sequence-bounds namestr start end)))
(multiple-value-bind (new-host device directory file type version)
(cond
- (host (funcall (host-parse-native host) namestr start end))
+ (host
+ (funcall (host-parse-native host) namestr start end))
((pathname-host defaults)
(funcall (host-parse-native (pathname-host defaults))
namestr
@@ -1282,6 +1283,12 @@
;;;; utilities
+(defun simplify-namestring (namestring &optional host)
+ (funcall (host-simplify-namestring
+ (or host
+ (pathname-host (sane-default-pathname-defaults))))
+ namestring))
+
;;; Canonicalize a logical pathname word by uppercasing it checking that it
;;; contains only legal characters.
(defun logical-word-or-lose (word)
@@ -1682,3 +1689,4 @@
;; FIXME: now that we have a SYS host that the system uses, it
;; might be cute to search in "SYS:TRANSLATIONS;<name>.LISP"
(error "logical host ~S not found" host)))
+
Index: toplevel.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v
retrieving revision 1.91
retrieving revision 1.92
diff -u -d -r1.91 -r1.92
--- toplevel.lisp 20 Sep 2006 12:08:22 -0000 1.91
+++ toplevel.lisp 26 Oct 2006 16:07:54 -0000 1.92
@@ -41,7 +41,7 @@
(defun sysinit-pathname ()
(or (let ((sbcl-homedir (sbcl-homedir-pathname)))
(when sbcl-homedir
- (probe-file (merge-pathnames sbcl-homedir "sbclrc"))))
+ (probe-file (merge-pathnames "sbclrc" sbcl-homedir))))
#!+win32
(merge-pathnames "sbcl\\sbclrc"
(sb!win32::get-folder-pathname
Index: unix-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix-pathname.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- unix-pathname.lisp 9 Sep 2006 08:00:03 -0000 1.5
+++ unix-pathname.lisp 26 Oct 2006 16:07:54 -0000 1.6
@@ -318,3 +318,89 @@
(strings ".")
(strings (unparse-unix-piece pathname-type))))
(apply #'concatenate 'simple-string (strings)))))
+
+(defun simplify-unix-namestring (src)
+ (declare (type simple-string src))
+ (let* ((src-len (length src))
+ (dst (make-string src-len :element-type 'character))
+ (dst-len 0)
+ (dots 0)
+ (last-slash nil))
+ (macrolet ((deposit (char)
+ `(progn
+ (setf (schar dst dst-len) ,char)
+ (incf dst-len))))
+ (dotimes (src-index src-len)
+ (let ((char (schar src src-index)))
+ (cond ((char= char #\.)
+ (when dots
+ (incf dots))
+ (deposit char))
+ ((char= char #\/)
+ (case dots
+ (0
+ ;; either ``/...' or ``...//...'
+ (unless last-slash
+ (setf last-slash dst-len)
+ (deposit char)))
+ (1
+ ;; either ``./...'' or ``..././...''
+ (decf dst-len))
+ (2
+ ;; We've found ..
+ (cond
+ ((and last-slash (not (zerop last-slash)))
+ ;; There is something before this ..
+ (let ((prev-prev-slash
+ (position #\/ dst :end last-slash :from-end t)))
+ (cond ((and (= (+ (or prev-prev-slash 0) 2)
+ last-slash)
+ (char= (schar dst (- last-slash 2)) #\.)
+ (char= (schar dst (1- last-slash)) #\.))
+ ;; The something before this .. is another ..
+ (deposit char)
+ (setf last-slash dst-len))
+ (t
+ ;; The something is some directory or other.
+ (setf dst-len
+ (if prev-prev-slash
+ (1+ prev-prev-slash)
+ 0))
+ (setf last-slash prev-prev-slash)))))
+ (t
+ ;; There is nothing before this .., so we need to keep it
+ (setf last-slash dst-len)
+ (deposit char))))
+ (t
+ ;; something other than a dot between slashes
+ (setf last-slash dst-len)
+ (deposit char)))
+ (setf dots 0))
+ (t
+ (setf dots nil)
+ (setf (schar dst dst-len) char)
+ (incf dst-len))))))
+ (when (and last-slash (not (zerop last-slash)))
+ (case dots
+ (1
+ ;; We've got ``foobar/.''
+ (decf dst-len))
+ (2
+ ;; We've got ``foobar/..''
+ (unless (and (>= last-slash 2)
+ (char= (schar dst (1- last-slash)) #\.)
+ (char= (schar dst (- last-slash 2)) #\.)
+ (or (= last-slash 2)
+ (char= (schar dst (- last-slash 3)) #\/)))
+ (let ((prev-prev-slash
+ (position #\/ dst :end last-slash :from-end t)))
+ (if prev-prev-slash
+ (setf dst-len (1+ prev-prev-slash))
+ (return-from simplify-unix-namestring
+ (coerce "./" 'simple-string))))))))
+ (cond ((zerop dst-len)
+ "./")
+ ((= dst-len src-len)
+ dst)
+ (t
+ (subseq dst 0 dst-len)))))
Index: unix.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix.lisp,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -d -r1.69 -r1.70
--- unix.lisp 26 Oct 2006 08:38:52 -0000 1.69
+++ unix.lisp 26 Oct 2006 16:07:54 -0000 1.70
@@ -907,7 +907,7 @@
(if (null link)
(return pathname)
(let ((new-pathname
- (unix-simplify-pathname
+ (simplify-namestring
(if (relative-unix-pathname? link)
(let* ((dir-len (1+ (position #\/
pathname
@@ -928,93 +928,6 @@
(if (member pathname previous-pathnames :test #'string=)
(return pathname)
(push pathname previous-pathnames))))
-
-(defun unix-simplify-pathname (src)
- (declare (type simple-string src))
- (let* ((src-len (length src))
- (dst (make-string src-len :element-type 'character))
- (dst-len 0)
- (dots 0)
- (last-slash nil))
- (macrolet ((deposit (char)
- `(progn
- (setf (schar dst dst-len) ,char)
- (incf dst-len))))
- (dotimes (src-index src-len)
- (let ((char (schar src src-index)))
- (cond ((char= char #\.)
- (when dots
- (incf dots))
- (deposit char))
- ((char= char #\/)
- (case dots
- (0
- ;; either ``/...' or ``...//...'
- (unless last-slash
- (setf last-slash dst-len)
- (deposit char)))
- (1
- ;; either ``./...'' or ``..././...''
- (decf dst-len))
- (2
- ;; We've found ..
- (cond
- ((and last-slash (not (zerop last-slash)))
- ;; There is something before this ..
- (let ((prev-prev-slash
- (position #\/ dst :end last-slash :from-end t)))
- (cond ((and (= (+ (or prev-prev-slash 0) 2)
- last-slash)
- (char= (schar dst (- last-slash 2)) #\.)
- (char= (schar dst (1- last-slash)) #\.))
- ;; The something before this .. is another ..
- (deposit char)
- (setf last-slash dst-len))
- (t
- ;; The something is some directory or other.
- (setf dst-len
- (if prev-prev-slash
- (1+ prev-prev-slash)
- 0))
- (setf last-slash prev-prev-slash)))))
- (t
- ;; There is nothing before this .., so we need to keep it
- (setf last-slash dst-len)
- (deposit char))))
- (t
- ;; something other than a dot between slashes
- (setf last-slash dst-len)
- (deposit char)))
- (setf dots 0))
- (t
- (setf dots nil)
- (setf (schar dst dst-len) char)
- (incf dst-len))))))
- (when (and last-slash (not (zerop last-slash)))
- (case dots
- (1
- ;; We've got ``foobar/.''
- (decf dst-len))
- (2
- ;; We've got ``foobar/..''
- (unless (and (>= last-slash 2)
- (char= (schar dst (1- last-slash)) #\.)
- (char= (schar dst (- last-slash 2)) #\.)
- (or (= last-slash 2)
- (char= (schar dst (- last-slash 3)) #\/)))
- (let ((prev-prev-slash
- (position #\/ dst :end last-slash :from-end t)))
- (if prev-prev-slash
- (setf dst-len (1+ prev-prev-slash))
- (return-from unix-simplify-pathname
- (coerce "./" 'simple-string))))))))
- (cond ((zerop dst-len)
- "./")
- ((= dst-len src-len)
- dst)
- (t
- (subseq dst 0 dst-len)))))
-
;;; UNIX specific code, that has been cleanly separated from the
;;; Windows build.
Index: win32-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/win32-pathname.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- win32-pathname.lisp 9 Sep 2006 08:00:03 -0000 1.5
+++ win32-pathname.lisp 26 Oct 2006 16:07:54 -0000 1.6
@@ -31,14 +31,14 @@
;; Next, split the remainder into slash-separated chunks.
(collect ((pieces))
(loop
- (let ((slash (position-if (lambda (c)
- (or (char= c #\/)
- (char= c #\\)))
- namestr :start start :end end)))
- (pieces (cons start (or slash end)))
- (unless slash
- (return))
- (setf start (1+ slash))))
+ (let ((slash (position-if (lambda (c)
+ (or (char= c #\/)
+ (char= c #\\)))
+ namestr :start start :end end)))
+ (pieces (cons start (or slash end)))
+ (unless slash
+ (return))
+ (setf start (1+ slash))))
(values absolute (pieces)))))
(defun parse-win32-namestring (namestring start end)
@@ -109,7 +109,7 @@
for piece = (subseq namestring start end)
collect (if (and (string= piece "..") rest)
:up
- piece)))
+ piece)))
(name-and-type
(let* ((end (first (last components)))
(dot (position #\. end :from-end t)))
@@ -273,18 +273,18 @@
(unless directory (go :done))
:subdir
(let ((piece (pop directory)))
- (typecase piece
+ (typecase piece
((member :up) (write-string ".." s))
(string (write-string piece s))
- (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece))))
+ (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
+ (when (or directory name type)
+ (write-char #\\ s)))
(when directory
- (write-char #\\ s)
(go :subdir))
:done)
(when name
(unless (stringp name)
(error "non-STRING name in NATIVE-NAMESTRING: ~S" name))
- (write-char #\\ s)
(write-string name s)
(when type
(unless (stringp type)
@@ -346,3 +346,93 @@
(strings ".")
(strings (unparse-unix-piece pathname-type))))
(apply #'concatenate 'simple-string (strings)))))
+
+;; FIXME: This has been converted rather blindly from the Unix
+;; version, with no reference to any Windows docs what so ever.
+(defun simplify-win32-namestring (src)
+ (declare (type simple-string src))
+ (let* ((src-len (length src))
+ (dst (make-string src-len :element-type 'character))
+ (dst-len 0)
+ (dots 0)
+ (last-slash nil))
+ (flet ((deposit (char)
+ (setf (schar dst dst-len) char)
+ (incf dst-len))
+ (slashp (char)
+ (find char "\\/")))
+ (dotimes (src-index src-len)
+ (let ((char (schar src src-index)))
+ (cond ((char= char #\.)
+ (when dots
+ (incf dots))
+ (deposit char))
+ ((slashp char)
+ (case dots
+ (0
+ ;; either ``/...' or ``...//...'
+ (unless last-slash
+ (setf last-slash dst-len)
+ (deposit char)))
+ (1
+ ;; either ``./...'' or ``..././...''
+ (decf dst-len))
+ (2
+ ;; We've found ..
+ (cond
+ ((and last-slash (not (zerop last-slash)))
+ ;; There is something before this ..
+ (let ((prev-prev-slash
+ (position-if #'slashp dst :end last-slash :from-end t)))
+ (cond ((and (= (+ (or prev-prev-slash 0) 2)
+ last-slash)
+ (char= (schar dst (- last-slash 2)) #\.)
+ (char= (schar dst (1- last-slash)) #\.))
+ ;; The something before this .. is another ..
+ (deposit char)
+ (setf last-slash dst-len))
+ (t
+ ;; The something is some directory or other.
+ (setf dst-len
+ (if prev-prev-slash
+ (1+ prev-prev-slash)
+ 0))
+ (setf last-slash prev-prev-slash)))))
+ (t
+ ;; There is nothing before this .., so we need to keep it
+ (setf last-slash dst-len)
+ (deposit char))))
+ (t
+ ;; something other than a dot between slashes
+ (setf last-slash dst-len)
+ (deposit char)))
+ (setf dots 0))
+ (t
+ (setf dots nil)
+ (setf (schar dst dst-len) char)
+ (incf dst-len)))))
+ ;; ...finish off
+ (when (and last-slash (not (zerop last-slash)))
+ (case dots
+ (1
+ ;; We've got ``foobar/.''
+ (decf dst-len))
+ (2
+ ;; We've got ``foobar/..''
+ (unless (and (>= last-slash 2)
+ (char= (schar dst (1- last-slash)) #\.)
+ (char= (schar dst (- last-slash 2)) #\.)
+ (or (= last-slash 2)
+ (slashp (schar dst (- last-slash 3)))))
+ (let ((prev-prev-slash
+ (position-if #'slashp dst :end last-slash :from-end t)))
+ (if prev-prev-slash
+ (setf dst-len (1+ prev-prev-slash))
+ (return-from simplify-win32-namestring
+ (coerce ".\\" 'simple-string)))))))))
+ (cond ((zerop dst-len)
+ ".\\")
+ ((= dst-len src-len)
+ dst)
+ (t
+ (subseq dst 0 dst-len)))))
|