From f28068a79825f37002e96d13dfd739172382bf94 Mon Sep 17 00:00:00 2001 From: Shinmera Date: Wed, 27 Dec 2023 18:36:28 +0100 Subject: [PATCH] Better handling of special pathname components in namestrings --- documentation.lisp | 11 +++++++ test.lisp | 11 +++++-- toolkit.lisp | 82 +++++++++++++++++++++++++++++++++------------- 3 files changed, 79 insertions(+), 25 deletions(-) diff --git a/documentation.lisp b/documentation.lisp index 47abd1f..61bc690 100644 --- a/documentation.lisp +++ b/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")) diff --git a/test.lisp b/test.lisp index 05fb004..55112bc 100644 --- a/test.lisp +++ b/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)))) diff --git a/toolkit.lisp b/toolkit.lisp index 2f3d570..dfb7078 100644 --- a/toolkit.lisp +++ b/toolkit.lisp @@ -478,7 +478,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))) (unix-namestring (user-homedir-pathname) :stream stream) @@ -486,21 +487,45 @@ ((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)))))