[Sbcl-commits] CVS: sbcl/src/code target-pathname.lisp, 1.58, 1.59 unix-pathname.lisp, 1.7, 1.8 win32-pathname.lisp, 1.8, 1.9

[Richard M K. <kr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv25628/src/code

Modified Files:
	target-pathname.lisp unix-pathname.lisp win32-pathname.lisp 
Log Message:
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.



Index: target-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-pathname.lisp,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -d -r1.58 -r1.59
--- target-pathname.lisp	14 Nov 2007 18:30:15 -0000	1.58
+++ target-pathname.lisp	30 Nov 2007 02:16:27 -0000	1.59
@@ -843,7 +843,8 @@
                     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 @@
        (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 @@
                                 &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 @@
       (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 @@
                   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 @@
         (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

Index: unix-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix-pathname.lisp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- unix-pathname.lisp	3 Dec 2006 19:53:52 -0000	1.7
+++ unix-pathname.lisp	30 Nov 2007 02:16:27 -0000	1.8
@@ -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)

Index: win32-pathname.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/win32-pathname.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- win32-pathname.lisp	3 Dec 2006 19:53:52 -0000	1.8
+++ win32-pathname.lisp	30 Nov 2007 02:16:27 -0000	1.9
@@ -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.