Better handling of special pathname components in namestrings

documentation.lisp

@@ -507,6 +507,12 @@ the error is continued or :JUNK-ALLOWED T is passed, the component or
 character is ignored. The following characters are illegal:
   / Nul
 
+Any component that isn't one of the following is considered illegal:
+  :BACK :UP :WILD :WILD-INFERIORS :UNSPECIFIC :HOME NIL string
+As the representation is implementation-internal. A wild component is
+outputted using \"glob\" syntax, meaning :WILD becomes * and
+:WILD-INFERIORS becomes ** .
+
 If STREAM is NIL, the namestring is printed to a string and returned.
 
 See NATIVE-NAMESTRING")
@@ -532,6 +538,11 @@ the error is continued or :JUNK-ALLOWED T is passed, the component or
 character is ignored. The following characters are illegal:
   \\ / < > : \" | ? * Nul
 
+Any component that isn't one of the following is considered illegal:
+  :BACK :UP :UNSPECIFIC :HOME NIL string
+As the representation is implementation-internal and DOS has no syntax
+for wild pathname patterns.
+
 If STREAM is NIL, the namestring is printed to a string and returned.
 
 See NATIVE-NAMESTRING"))

test.lisp

@@ -377,7 +377,7 @@
   (is equal #p "a/b/c" (parse-dos-namestring "a/b/c"))
   (is equal #p "/a/b/c" (parse-dos-namestring "\\a\\b\\c"))
   (is equal #p "a/b/c" (parse-dos-namestring "a\\b\\c"))
-  #+windows (is equal #p "C:/a/b/c" (parse-dos-namestring "C:\\a\\b\\c"))
+  #+windows (is equal #p"C:/a/b/c" (parse-dos-namestring "C:\\a\\b\\c"))
   #+windows (is equal (user-homedir-pathname) (parse-dos-namestring "%UserProfile%/")))
 
 (define-test unix-namestring
@@ -387,7 +387,10 @@
   (is equal "a" (unix-namestring #p"a"))
   (is equal "a.b" (unix-namestring (make-pathname :name "a" :type "b")))
   (is equal "/a/b" (unix-namestring (make-pathname :name "b" :directory '(:absolute "a"))))
-  (is equal "a/b" (unix-namestring (make-pathname :name "b" :directory '(:relative "a")))))
+  (is equal "a/b" (unix-namestring (make-pathname :name "b" :directory '(:relative "a"))))
+  (is equal "" (unix-namestring (make-pathname :name :unspecific)))
+  (is equal "*" (unix-namestring (make-pathname :name :wild)))
+  (is equal "**/" (unix-namestring (make-pathname :directory '(:relative :wild-inferiors)))))
 
 (define-test dos-namestring
   :parent namestrings
@@ -399,4 +402,6 @@
   (is equal "\\a\\b" (dos-namestring (make-pathname :name "b" :directory '(:absolute "a"))))
   (is equal "a\\b" (dos-namestring (make-pathname :name "b" :directory '(:relative "a"))))
   (is equal "c:\\" (dos-namestring (make-pathname :device "c" :directory '(:absolute))))
-  (is equal "a\\" (dos-namestring (make-pathname :device "c" :directory '(:relative "a")))))
+  (is equal "a\\" (dos-namestring (make-pathname :device "c" :directory '(:relative "a"))))
+  (is equal "" (dos-namestring (make-pathname :name :unspecific)))
+  (fail (dos-namestring (make-pathname :name :wild))))

toolkit.lisp

@@ -478,29 +478,54 @@
                                     char pathname)))
                          (T
                           (write-char char stream))))))
-       (let ((dir (pathname-directory pathname)))
+       (let* ((pathname (normalize-pathname pathname))
+              (dir (pathname-directory pathname)))
          (cond ((and (eql :absolute (first dir))
                      (eql :home (second dir)))
                 (unix-namestring (user-homedir-pathname) :stream stream)
                 (setf dir (cdr dir)))
                ((eql :absolute (first dir))
                 (write-char #\/ stream)))
          (loop for component in (rest dir)
-               do (cond ((find component '(:back :up))
-                         (write-part ".."))
-                        ((find component '(".." ".") :test #'string=)
-                         (unless junk-allowed
-                           (cerror "Print the component anyway" "Illegal directory ~s in pathname:~%  ~a"
-                                   component pathname))
-                         (write-part component))
-                        (T (write-part component)))
-                  (write-char #\/ stream)))
-       (when (pathname-name pathname)
-         (write-part (pathname-name pathname)))
-       (when (pathname-type pathname)
-         (write-char #\. stream)
-         (write-part (pathname-type pathname))))
-     stream)))
+               do (typecase component
+                    ((member :back :up)
+                     (write-part ".."))
+                    ((eql :wild)
+                     (write-string "*" stream))
+                    ((eql :wild-inferiors)
+                     (write-string "**" stream))
+                    (string
+                     (when (find component '(".." ".") :test #'string=)
+                       (unless junk-allowed
+                         (cerror "Print the component anyway" "Illegal directory ~s in pathname:~%  ~a"
+                                 component pathname)))
+                     (write-part component))
+                    (T
+                     (cerror "Omit the component" "Illegal directory ~s in pathname:~%  ~a"
+                             component pathname)))
+                  (write-char #\/ stream))
+         (typecase (pathname-name pathname)
+           (null)
+           ((eql :wild)
+            (write-string "*" stream))
+           (string
+            (write-part (pathname-name pathname)))
+           (T
+            (unless junk-allowed
+              (cerror "Omit the component" "Illegal name ~s in pathname:~%  ~a"
+                      (pathname-name pathname) pathname))))
+         (typecase (pathname-type pathname)
+           (null)
+           ((eql :wild)
+            (write-string ".*" stream))
+           (string
+            (write-char #\. stream)
+            (write-part (pathname-type pathname)))
+           (T
+            (unless junk-allowed
+              (cerror "Omit the component" "Illegal name ~s in pathname:~%  ~a"
+                      (pathname-name pathname) pathname))))
+         stream)))))
 
 (defun dos-namestring (pathname &key (stream) junk-allowed)
   (etypecase stream
@@ -517,7 +542,8 @@
                                     char pathname)))
                          (T
                           (write-char char stream))))))
-       (let ((dir (pathname-directory pathname)))
+       (let* ((pathname (normalize-pathname pathname))
+              (dir (pathname-directory pathname)))
          (cond ((and (eql :absolute (first dir))
                      (eql :home (second dir)))
                 (dos-namestring (user-homedir-pathname) :stream stream)
@@ -537,9 +563,21 @@
                          (write-part component))
                         (T (write-part component)))
                   (write-char #\\ stream))
-         (when (pathname-name pathname)
-           (write-part (pathname-name pathname)))
-         (when (pathname-type pathname)
-           (write-char #\. stream)
-           (write-part (pathname-type pathname)))
+         (typecase (pathname-name pathname)
+           (null)
+           (string
+            (write-part (pathname-name pathname)))
+           (T
+            (unless junk-allowed
+              (cerror "Omit the component" "Illegal name ~s in pathname:~%  ~a"
+                      (pathname-name pathname) pathname))))
+         (typecase (pathname-type pathname)
+           (null)
+           (string
+            (write-char #\. stream)
+            (write-part (pathname-type pathname)))
+           (T
+            (unless junk-allowed
+              (cerror "Omit the component" "Illegal name ~s in pathname:~%  ~a"
+                      (pathname-name pathname) pathname))))
          stream)))))