From c33b7b7a45c3fa7f178b1fa660ab98a2de09598b Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Mon, 12 Sep 2005 14:38:17 +0000 Subject: [PATCH] Fix some issues with printing (make-pathname :directory '(:relative)), which used to print as #p"", and with reading #p".", #p"./". code/filesys.lisp: o When parsing a unix namestring, delete any "." elements of the directory list. o If we've parsed a namestring such that the file name is ".", replace that with :name NIL and adjust the :directory component appropriately, because on Unix, "." can't be the name of a file. o Make :directory '(:relative) be printed as "./" code/pathname.lisp: o If the :directory argument to MAKE-PATHNAME contains strings with #\/, print a warning that this is not a valid element. o Remove all "."'s from a :relative directory component. --- code/filesys.lisp | 23 ++++++++++++++++++----- code/pathname.lisp | 22 +++++++++++++++++++--- 2 files changed, 37 insertions(+), 8 deletions(-) diff --git a/code/filesys.lisp b/code/filesys.lisp index 8476d449c..2327cc0ac 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 256b321fa..353cb34ba 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. -- GitLab