;;;; -*- 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 >
@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
@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
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)
(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
&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)
(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))
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
(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
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))
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))))
(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)
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))
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)))))
(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
(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.
;;; enough-namestring relative to root
(assert (equal "foo" (enough-namestring "/foo" "/")))
-
+\f
+;;; 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
;;; 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"
projects / sbcl.git / commitdiff