From 2529c316d05494f2bcdeccf98c3a6298ecd08d7d Mon Sep 17 00:00:00 2001 From: kreuter Date: Fri, 30 Nov 2007 02:16:25 +0000 Subject: [PATCH] 1.0.12.6: Removing UNIX-NAMESTRING, part 1 * Get NATIVE-NAMESTRING to do all and only the desired things for all accepted non-wild NAME and TYPE components. Add a few tests for these cases. * Add new user-visible features to PARSE-NATIVE-NAMESTRING and NATIVE-NAMESTRING for parsing/unparsing things "as files" or "as directories"; these are convenient for use with SB-POSIX, and will be handy in a few places in SBCL's internals, too. --- NEWS | 4 ++ contrib/sb-posix/sb-posix.texinfo | 8 ++-- doc/manual/pathnames.texinfo | 41 +++++++++++++++++ src/code/target-pathname.lisp | 38 ++++++++++------ src/code/unix-pathname.lisp | 87 +++++++++++++++++++++++-------------- src/code/win32-pathname.lisp | 77 +++++++++++++++++++------------- tests/pathnames.impure.lisp | 31 ++++++++++++- version.lisp-expr | 2 +- 8 files changed, 207 insertions(+), 81 deletions(-) diff --git a/NEWS b/NEWS index 6b6f3cc..bd55399 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,9 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-1.0.13 relative to sbcl-1.0.12: + * SB-EXT:NATIVE-NAMESTRING takes a new keyword AS-FILE, forcing + unparsing of directory pathnames as files. Analogously, + SB-EXT:PARSE-NATIVE-NAMESTRING takes an AS-DIRECTORY, forcing a + filename to parse into a directory pathname. * bug fix: some sequence functions elided bounds checking when SPEED > SAFETY. * bug fix: too liberal weakening of union-type checks when SPEED > diff --git a/contrib/sb-posix/sb-posix.texinfo b/contrib/sb-posix/sb-posix.texinfo index 61b4bf7..061c36a 100644 --- a/contrib/sb-posix/sb-posix.texinfo +++ b/contrib/sb-posix/sb-posix.texinfo @@ -110,9 +110,11 @@ name of a directory in POSIX filename syntax into a pathname @end lisp @noindent -returns a pathname that denotes a file in the directory, it's necessary -to append a forward slash to the POSIX filename. Otherwise, the last -directory name will be parsed as a filename. +returns a pathname that denotes a file in the directory, supply a true +@code{AS-DIRECTORY} argument to @code{SB-EXT:PARSE-NATIVE-NAMESTRING}. +Likewise, if it is necessary to supply the name of a directory to a +POSIX function in non-directory syntax, supply a true @code{AS-FILE} +argument to @code{SB-EXT:NATIVE-NAMESTRING}. @node Type conversion functions @subsubsection Type conversion functions diff --git a/doc/manual/pathnames.texinfo b/doc/manual/pathnames.texinfo index cf859b1..02687c8 100644 --- a/doc/manual/pathnames.texinfo +++ b/doc/manual/pathnames.texinfo @@ -107,7 +107,48 @@ namestring, if possible. Some Lisp pathname concepts (such as the @code{:back} directory component) have no direct equivalents in most Operating Systems; the behaviour of @code{native-namestring} is unspecified if an inappropriate pathname designator is passed to it. +Additionally, note that conversion from pathname to native filename +and back to pathname should not be expected to preserve equivalence +under @code{equal}. @include fun-sb-ext-parse-native-namestring.texinfo @include fun-sb-ext-native-pathname.texinfo @include fun-sb-ext-native-namestring.texinfo + +Because some file systems permit the names of directories to be +expressed in multiple ways, it is occasionally necessary to parse a +native file name ``as a directory name'' or to produce a native file +name that names a directory ``as a file''. For these cases, +@code{parse-native-namestring} accepts the keyword argument +@code{as-directory} to force a filename to parse as a directory, and +@code{native-namestring} accepts the keyword argument @code{as-file} +to force a pathname to unparse as a file. For example, + +@lisp +; On Unix, the directory "/tmp/" can be denoted by "/tmp/" or "/tmp". +; Under the default rules for native filenames, these parse and +; unparse differently. +(defvar *p*) +(setf *p* (parse-native-namestring "/tmp/")) @result{} #P"/tmp/" +(pathname-name *p*) @result{} NIL +(pathname-directory *p*) @result{} (:ABSOLUTE "tmp") +(native-namestring *p*) @result{} "/tmp/" + +(setf *p* (parse-native-namestring "/tmp")) @result{} #P"/tmp" +(pathname-name *p*) @result{} "tmp" +(pathname-directory *p*) @result{} (:ABSOLUTE) +(native-namestring *p*) @result{} "/tmp" + +; A non-NIL AS-DIRECTORY argument to PARSE-NATIVE-NAMESTRING forces +; both the second string to parse the way the first does. +(setf *p* (parse-native-namestring "/tmp" + nil *default-pathname-defaults* + :as-directory t)) @result{} #P"/tmp/" +(pathname-name *p*) @result{} NIL +(pathname-directory *p*) @result{} (:ABSOLUTE "tmp") + +; A non-NIL AS-FILE argument to NATIVE-NAMESTRING forces the pathname +; parsed from the first string to unparse as the second string. +(setf *p* (parse-native-namestring "/tmp/")) @result{} #P"/tmp/" +(native-namestring *p* :as-file t) @result{} "/tmp" +@end lisp diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index f32e656..109f639 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -843,7 +843,8 @@ a host-structure or string." thing)) (values name nil))))))) -(defun %parse-native-namestring (namestr host defaults start end junk-allowed) +(defun %parse-native-namestring (namestr host defaults start end junk-allowed + as-directory) (declare (type (or host null) host) (type string namestr) (type index start) @@ -859,12 +860,13 @@ a host-structure or string." (multiple-value-bind (new-host device directory file type version) (cond (host - (funcall (host-parse-native host) namestr start end)) + (funcall (host-parse-native host) namestr start end as-directory)) ((pathname-host defaults) (funcall (host-parse-native (pathname-host defaults)) namestr start - end)) + end + as-directory)) ;; I don't think we should ever get here, as the default ;; host will always have a non-null HOST, given that we ;; can't create a new pathname without going through @@ -888,13 +890,17 @@ a host-structure or string." &optional host (defaults *default-pathname-defaults*) - &key (start 0) end junk-allowed) + &key (start 0) end junk-allowed + as-directory) #!+sb-doc "Convert THING into a pathname, using the native conventions -appropriate for the pathname host HOST, or if not specified the host -of DEFAULTS. If THING is a string, the parse is bounded by START and -END, and error behaviour is controlled by JUNK-ALLOWED, as with -PARSE-NAMESTRING." +appropriate for the pathname host HOST, or if not specified the +host of DEFAULTS. If THING is a string, the parse is bounded by +START and END, and error behaviour is controlled by JUNK-ALLOWED, +as with PARSE-NAMESTRING. For file systems whose native +conventions allow directories to be indicated as files, if +AS-DIRECTORY is true, return a pathname denoting THING as a +directory." (declare (type pathname-designator thing defaults) (type (or list host string (member :unspecific)) host) (type index start) @@ -914,10 +920,11 @@ PARSE-NAMESTRING." (etypecase thing (simple-string (%parse-native-namestring - thing found-host defaults start end junk-allowed)) + thing found-host defaults start end junk-allowed as-directory)) (string (%parse-native-namestring (coerce thing 'simple-string) - found-host defaults start end junk-allowed)) + found-host defaults start end junk-allowed + as-directory)) (pathname (let ((defaulted-host (or found-host (%pathname-host defaults)))) (declare (type host defaulted-host)) @@ -946,9 +953,14 @@ PARSE-NAMESTRING." host:~% ~S" pathname)) (funcall (host-unparse host) pathname))))) -(defun native-namestring (pathname) +(defun native-namestring (pathname &key as-file) #!+sb-doc - "Construct the full native (name)string form of PATHNAME." + "Construct the full native (name)string form of PATHNAME. For +file systems whose native conventions allow directories to be +indicated as files, if AS-FILE is true and the name, type, and +version components of PATHNAME are all NIL or :UNSPECIFIC, +construct a string that names the directory according to the file +system's syntax for files." (declare (type pathname-designator pathname)) (with-native-pathname (pathname pathname) (when pathname @@ -956,7 +968,7 @@ PARSE-NAMESTRING." (unless host (error "can't determine the native namestring for pathnames with no ~ host:~% ~S" pathname)) - (funcall (host-unparse-native host) pathname))))) + (funcall (host-unparse-native host) pathname as-file))))) (defun host-namestring (pathname) #!+sb-doc diff --git a/src/code/unix-pathname.lisp b/src/code/unix-pathname.lisp index dc842b1..e7faa3e 100644 --- a/src/code/unix-pathname.lisp +++ b/src/code/unix-pathname.lisp @@ -85,7 +85,7 @@ type version)))) -(defun parse-native-unix-namestring (namestring start end) +(defun parse-native-unix-namestring (namestring start end as-directory) (declare (type simple-string namestring) (type index start end)) (setf namestring (coerce namestring 'simple-string)) @@ -96,22 +96,27 @@ collect (if (and (string= piece "..") rest) :up piece))) + (directory (if (and as-directory + (string/= "" (car (last components)))) + components + (butlast components))) (name-and-type - (let* ((end (first (last components))) - (dot (position #\. end :from-end t))) - ;; FIXME: can we get this dot-interpretation knowledge - ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION - ;; does slightly more work than that. - (cond - ((string= end "") - (list nil nil)) - ((and dot (> dot 0)) - (list (subseq end 0 dot) (subseq end (1+ dot)))) - (t - (list end nil)))))) + (unless as-directory + (let* ((end (first (last components))) + (dot (position #\. end :from-end t))) + ;; FIXME: can we get this dot-interpretation knowledge + ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION + ;; does slightly more work than that. + (cond + ((string= end "") + (list nil nil)) + ((and dot (> dot 0)) + (list (subseq end 0 dot) (subseq end (1+ dot)))) + (t + (list end nil))))))) (values nil nil - (cons (if absolute :absolute :relative) (butlast components)) + (cons (if absolute :absolute :relative) directory) (first name-and-type) (second name-and-type) nil)))) @@ -238,32 +243,48 @@ (unparse-unix-directory pathname) (unparse-unix-file pathname))) -(defun unparse-native-unix-namestring (pathname) +(defun unparse-native-unix-namestring (pathname as-file) (declare (type pathname pathname)) - (let ((directory (pathname-directory pathname)) - (name (pathname-name pathname)) - (type (pathname-type pathname))) + (let* ((directory (pathname-directory pathname)) + (name (pathname-name pathname)) + (name-present-p (typep name '(not (member nil :unspecific)))) + (name-string (if name-present-p name "")) + (type (pathname-type pathname)) + (type-present-p (typep type '(not (member nil :unspecific)))) + (type-string (if type-present-p type ""))) + (when name-present-p + (setf as-file nil)) (coerce (with-output-to-string (s) (when directory (ecase (car directory) (:absolute (write-char #\/ s)) (:relative))) - (dolist (piece (cdr directory)) - (typecase piece - ((member :up) (write-string ".." s)) - (string (write-string piece s)) - (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece))) - (write-char #\/ s)) - (when name - (unless (stringp name) - (error "non-STRING name in NATIVE-NAMESTRING: ~S" name)) - (write-string name s) - (when type - (unless (stringp type) - (error "non-STRING type in NATIVE-NAMESTRING: ~S" name)) - (write-char #\. s) - (write-string type s)))) + (loop for (piece . subdirs) on (cdr directory) + do (typecase piece + ((member :up) (write-string ".." s)) + (string (write-string piece s)) + (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S" + piece))) + if (or subdirs (stringp name)) + do (write-char #\/ s) + else + do (unless as-file + (write-char #\/ s))) + (if name-present-p + (progn + (unless (stringp name-string) ;some kind of wild field + (error "ungood name component in NATIVE-NAMESTRING: ~S" name)) + (write-string name-string s) + (when type-present-p + (unless (stringp type-string) ;some kind of wild field + (error "ungood type component in NATIVE-NAMESTRING: ~S" type)) + (write-char #\. s) + (write-string type-string s))) + (when type-present-p ; type without a name + (error + "type component without a name component in NATIVE-NAMESTRING: ~S" + type)))) 'simple-string))) (defun unparse-unix-enough (pathname defaults) diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index 480877c..f904d6e 100644 --- a/src/code/win32-pathname.lisp +++ b/src/code/win32-pathname.lisp @@ -97,7 +97,7 @@ type version))))) -(defun parse-native-win32-namestring (namestring start end) +(defun parse-native-win32-namestring (namestring start end as-directory) (declare (type simple-string namestring) (type index start end)) (setf namestring (coerce namestring 'simple-string)) @@ -110,22 +110,27 @@ collect (if (and (string= piece "..") rest) :up piece))) + (directory (if (and as-directory + (string/= "" (car (last components)))) + components + (butlast components))) (name-and-type - (let* ((end (first (last components))) - (dot (position #\. end :from-end t))) - ;; FIXME: can we get this dot-interpretation knowledge - ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION - ;; does slightly more work than that. - (cond - ((string= end "") - (list nil nil)) - ((and dot (> dot 0)) - (list (subseq end 0 dot) (subseq end (1+ dot)))) - (t - (list end nil)))))) + (unless as-directory + (let* ((end (first (last components))) + (dot (position #\. end :from-end t))) + ;; FIXME: can we get this dot-interpretation knowledge + ;; from existing code? EXTRACT-NAME-TYPE-AND-VERSION + ;; does slightly more work than that. + (cond + ((string= end "") + (list nil nil)) + ((and dot (> dot 0)) + (list (subseq end 0 dot) (subseq end (1+ dot)))) + (t + (list end nil))))))) (values nil device - (cons (if absolute :absolute :relative) (butlast components)) + (cons (if absolute :absolute :relative) directory) (first name-and-type) (second name-and-type) nil))))) @@ -255,12 +260,18 @@ (unparse-win32-directory pathname) (unparse-win32-file pathname))) -(defun unparse-native-win32-namestring (pathname) +(defun unparse-native-win32-namestring (pathname as-file) (declare (type pathname pathname)) - (let ((device (pathname-device pathname)) - (directory (pathname-directory pathname)) - (name (pathname-name pathname)) - (type (pathname-type pathname))) + (let* ((device (pathname-device pathname)) + (directory (pathname-directory pathname)) + (name (pathname-name pathname)) + (name-present-p (typep name '(not (member nil :unspecific)))) + (name-string (if name-present-p name "")) + (type (pathname-type pathname)) + (type-present-p (typep type '(not (member nil :unspecific)))) + (type-string (if type-present-p type ""))) + (when name-present-p + (setf as-file nil)) (coerce (with-output-to-string (s) (when device @@ -276,21 +287,27 @@ (typecase piece ((member :up) (write-string ".." s)) (string (write-string piece s)) - (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece))) - (when (or directory name type) + (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S" + piece))) + (when (or directory (not as-file)) (write-char #\\ s))) (when directory (go :subdir)) :done) - (when name - (unless (stringp name) - (error "non-STRING name in NATIVE-NAMESTRING: ~S" name)) - (write-string name s) - (when type - (unless (stringp type) - (error "non-STRING type in NATIVE-NAMESTRING: ~S" name)) - (write-char #\. s) - (write-string type s)))) + (if name-present-p + (progn + (unless (stringp name-string) ;some kind of wild field + (error "ungood name component in NATIVE-NAMESTRING: ~S" name)) + (write-string name-string s) + (when type-present-p + (unless (stringp type-string) ;some kind of wild field + (error "ungood type component in NATIVE-NAMESTRING: ~S" type)) + (write-char #\. s) + (write-string type-string s))) + (when type-present-p ; + (error + "type component without a name component in NATIVE-NAMESTRING: ~S" + type)))) 'simple-string))) ;;; FIXME. diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index c81cb5a..bd90a42 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -427,5 +427,34 @@ ;;; enough-namestring relative to root (assert (equal "foo" (enough-namestring "/foo" "/"))) - + +;;; Check the handling of NIL, :UNSPECIFIC, the empty string, and +;;; non-NIL strings in NATIVE-NAMESTRING implementations. Revised by +;;; RMK 2007-11-28, attempting to preserve the apparent intended +;;; denotation of SBCL's then-current pathname implementation. +(assert (equal + (loop with components = (list nil :unspecific "" "a") + for name in components + appending (loop for type in components + as pathname = (make-pathname + #+win32 "C" + :directory '(:absolute "tmp") + :name name :type type) + collect (ignore-errors + (sb-ext:native-namestring pathname)))) + #-win32 + #|type NIL :UNSPECIFIC "" "a" |# +#|name |# +#|NIL |# '("/tmp/" "/tmp/" NIL NIL +#|:UNSPECIFIC|# "/tmp/" "/tmp/" NIL NIL +#|"" |# "/tmp/" "/tmp/" "/tmp/." "/tmp/.a" +#|"a" |# "/tmp/a" "/tmp/a" "/tmp/a." "/tmp/a.a") + + #+win32 + #|type NIL :UNSPECIFIC "" "a" |# +#|name |# +#|NIL |# '("C:\\tmp\\" "C:\\tmp\\" NIL NIL +#|:UNSPECIFIC|# "C:\\tmp\\" "C:\\tmp\\" NIL NIL +#|"" |# "C:\\tmp\\" "C:\\tmp\\" "C:\\tmp\\." "C:\\tmp\\.a" +#|"a" |# "C:\\tmp\\a" "C:\\tmp\\a" "C:\\tmp\\a." "C:\\tmp\\a.a"))) ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 79fcb0f..783e6f8 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.12.5" +"1.0.12.6" -- 1.7.10.4