diff --git a/code/filesys.lisp b/code/filesys.lisp index 8476d449c351bb07685b40547be16be29e8366a4..2327cc0ac6bdd908af0ec579d484eaaea91e13fc 100644 --- a/code/filesys.lisp +++ b/code/filesys.lisp @@ -6,7 +6,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.88 2005/08/31 13:57:08 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.89 2005/09/12 14:38:17 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -339,10 +339,21 @@ (cond (absolute (cons :absolute (dirs))) ((dirs) - (cons :relative (dirs))) + ;; "." in a :relative directory is the same + ;; as if it weren't there, so remove them. + (cons :relative (delete "." (dirs) :test #'equal))) (t - nil))) - name + ;; If there is no directory and the name is + ;; ".", we really got directory ".", so make it so. + (if (equal name ".") + (list :relative) + nil)))) + ;; A file with name "." can't be the name of file on + ;; Unix because it's a directory. This was handled + ;; above, so we can just set the name to nil. + (if (equal name ".") + nil + name) type version))))) @@ -415,7 +426,9 @@ (t (pieces "/")))) (:relative - ;; Nothing special. + ;; Nothing special, except if we were given '(:relative). + (unless directory + (pieces "./")) )) (dolist (dir directory) (typecase dir diff --git a/code/pathname.lisp b/code/pathname.lisp index 256b321fa16e7cb8f856103e3278b94e520c5739..353cb34ba1d836e83d7bcfa238e4a13c633d9111 100644 --- a/code/pathname.lisp +++ b/code/pathname.lisp @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.73 2005/05/11 13:51:09 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pathname.lisp,v 1.74 2005/09/12 14:38:17 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -724,8 +724,24 @@ a host-structure or string." (warn "Silly argument for a unix ~A: ~S" name-or-type name))))))) (check-component-validity name :pathname-name) - (check-component-validity type :pathname-type)) - + (check-component-validity type :pathname-type) + (mapc #'(lambda (d) + (check-component-validity d :directory)) + (cdr dir))) + + ;; More sanity checking + (when dir + ;; Try to canonicalize the directory component. :absolute + ;; followed by a bunch of "/" deletes the leading "/"'s. + ;; :relative followed by "." anywhere gets them all deleted. + (ecase (first dir) + (:absolute + (do ((p (cdr dir) (cdr p))) + ((or (null p) + (not (equal "/" (car p)))) + (setf (cdr dir) p)))) + (:relative + (setf (cdr dir) (delete "." (cdr dir) :test #'equal))))) ;; CLHS 19.2.2.4.3 says :absolute or :wild-inferiors immediately ;; followed by :up or :back signals a file-error.