From: Nikodemus S. <de...@us...> - 2009-06-02 15:03:08
|
Update of /cvsroot/sbcl/sbcl/src/code In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv26192/src/code Modified Files: filesys.lisp Log Message: 1.0.28.71: two regressions from the 1.0.28. series * from 1.0.28.51: when destructuring a constant :INITIAL-CONTENTS to MAKE-ARRAY, take care to quote the elements. * from 1.0.28.61: handle :BACK and :UP in CANONICALIZE-PATHNAME, and make sure they do not appear after :WILD-INFERIORS or :ABSOLUTE. I'm more and more concinved that MAKE-PATHNAME should canonicalize, though, so that these checks don't need to be carried out by users of pathnames -- but leaving that for later. ...how appropriate that it is .71 that fixes both. Index: filesys.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/filesys.lisp,v retrieving revision 1.80 retrieving revision 1.81 diff -u -d -r1.80 -r1.81 --- filesys.lisp 22 May 2009 06:16:20 -0000 1.80 +++ filesys.lisp 2 Jun 2009 15:03:03 -0000 1.81 @@ -606,15 +606,33 @@ #'string< :key #'car)))) - (defun canonicalize-pathname (pathname) - ;; We're really only interested in :UNSPECIFIC -> NIL, - ;; and dealing with #p"foo/.." and #p"foo/." - (flet ((simplify (piece) - (unless (eq :unspecific piece) - piece))) - (let ((name (simplify (pathname-name pathname))) - (type (simplify (pathname-type pathname))) - (dir (pathname-directory pathname))) +(defun canonicalize-pathname (pathname) + ;; We're really only interested in :UNSPECIFIC -> NIL, :BACK and :UP, + ;; and dealing with #p"foo/.." and #p"foo/." + (labels ((simplify (piece) + (unless (eq :unspecific piece) + piece)) + (canonicalize-directory (directory) + (let (pieces) + (dolist (piece directory) + (if (and pieces (member piece '(:back :up))) + ;; FIXME: We should really canonicalize when we construct + ;; pathnames. This is just wrong. + (case (car pieces) + ((:absolute :wild-inferiors) + (error 'simple-file-error + :format-control "Invalid use of ~S after ~S." + :format-arguments (list piece (car pieces)) + :pathname pathname)) + ((:relative :up :back) + (push piece pieces)) + (t + (pop pieces))) + (push piece pieces))) + (nreverse pieces)))) + (let ((name (simplify (pathname-name pathname))) + (type (simplify (pathname-type pathname))) + (dir (canonicalize-directory (pathname-directory pathname)))) (cond ((equal "." name) (cond ((not type) (make-pathname :name nil :defaults pathname)) @@ -624,8 +642,9 @@ :directory (butlast dir) :defaults pathname)))) (t - (make-pathname :name name :type type :defaults pathname)))))) - + (make-pathname :name name :type type + :directory dir + :defaults pathname)))))) ;;; Given a native namestring, provides a WITH-HASH-TABLE-ITERATOR style ;;; interface to mapping over namestrings of entries in the corresponding |