Raymond Toy pushed to branch master at cmucl / cmucl Commits: bdd7294f by Raymond Toy at 2023-07-21T19:15:10+00:00 Fix #171: Readably print pathnames with :unspecific - - - - - 4bce99fc by Raymond Toy at 2023-07-21T19:15:11+00:00 Merge branch 'issue-171-readable-unspecific-pathnames' into 'master' Fix #171: Readably print pathnames with :unspecific Closes #171 See merge request cmucl/cmucl!134 - - - - - 2 changed files: - src/code/pathname.lisp - tests/pathname.lisp Changes: ===================================== src/code/pathname.lisp ===================================== @@ -121,58 +121,73 @@ (defun %print-pathname (pathname stream depth) (declare (ignore depth)) (let* ((host (%pathname-host pathname)) + (device (%pathname-device pathname)) + (directory (%pathname-directory pathname)) + (name (%pathname-name pathname)) + (type (%pathname-type pathname)) + (version (%pathname-version pathname)) + (unspecific-p (or (eq device :unspecific) + (eq name :unspecific) + (eq type :unspecific) + (eq version :unspecific))) (namestring (if host (handler-case (namestring pathname) (error nil)) nil))) - (cond (namestring + ;; A pathname with :UNSPECIFIC components has a namestring that + ;; ignores :UNSPECIFIC (and NIL). Thus the namestring exists, but + ;; we want to use our special syntax to print the pathname + ;; readably when :UNSPECIFIC occurs. + (cond ((and namestring (not unspecific-p)) (if (or *print-escape* *print-readably*) (format stream "#P~S" namestring) (format stream "~A" namestring))) (t - (let ((device (%pathname-device pathname)) - (directory (%pathname-directory pathname)) - (name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (version (%pathname-version pathname))) - (cond ((every #'(lambda (d) - (or (stringp d) - (symbolp d))) - (cdr directory)) - ;; A CMUCL extension. If we have an unprintable - ;; pathname, convert it to a form that would be - ;; suitable as args to MAKE-PATHNAME to recreate - ;; the pathname. - ;; - ;; We don't handle search-lists because we don't - ;; currently have a readable syntax for - ;; search-lists. - (collect ((result)) - (unless (eq host *unix-host*) - (result :host) - (result (if host - (pathname-host pathname) - nil))) - (when device - (result :device) - (result device)) - (when directory - (result :directory) - (result directory)) - (when name - (result :name) - (result name)) - (when type - (result :type) - (result type)) - (when version - (result :version) - (result version)) - (format stream "#P~S" (result)))) - (*print-readably* - (error 'print-not-readable :object pathname)) - (t - (funcall (formatter "#<Unprintable pathname,~:_ Host=~S,~:_ Device=~S,~:_ ~ + (cond ((and + ;; We only use the extension if the pathname does + ;; not contain a pattern object which doesn't print + ;; readably. Search-lists, which are part of the + ;; directory component, are excluded too. + (not (typep name 'pattern)) + (not (typep type 'pattern)) + (every #'(lambda (d) + (or (stringp d) + (symbolp d))) + (cdr directory))) + ;; A CMUCL extension. If we have an unprintable + ;; pathname, convert it to a form that would be + ;; suitable as args to MAKE-PATHNAME to recreate + ;; the pathname. + ;; + ;; We don't handle search-lists because we don't + ;; currently have a readable syntax for + ;; search-lists. + (collect ((result)) + (unless (eq host *unix-host*) + (result :host) + (result (if host + (pathname-host pathname) + nil))) + (when device + (result :device) + (result device)) + (when directory + (result :directory) + (result directory)) + (when name + (result :name) + (result name)) + (when type + (result :type) + (result type)) + (when version + (result :version) + (result version)) + (format stream "#P~S" (result)))) + (*print-readably* + (error 'print-not-readable :object pathname)) + (t + (funcall (formatter "#<Unprintable pathname,~:_ Host=~S,~:_ Device=~S,~:_ ~ Directory=~S,~:_ Name=~S,~:_ Type=~S,~:_ Version=~S>") stream (%pathname-host pathname) ===================================== tests/pathname.lisp ===================================== @@ -83,3 +83,31 @@ and type = (pathname-type f) do (assert-true (and (null name) (null type)) f)))) + + + +;; Test that pathnames with :unspecific components are printed using +;; our extension to make :unspecific explicit. +(define-test issue.171.unspecific + (:tag :issues) + (flet ((output (path) + (with-output-to-string (s) + (write path :stream s)))) + (dolist (test + (list + (list (make-pathname :name "foo" :type :unspecific) + "#P(:NAME \"foo\" :TYPE :UNSPECIFIC)" + "foo") + (list (make-pathname :name :unspecific :type "foo") + "#P(:NAME :UNSPECIFIC :TYPE \"foo\")" + ".foo") + (list (make-pathname :name "foo" :type "txt" :version :unspecific) + "#P(:NAME \"foo\" :TYPE \"txt\" :VERSION :UNSPECIFIC)" + "foo.txt") + (list (make-pathname :device :unspecific) + "#P(:DEVICE :UNSPECIFIC)" + ""))) + (destructuring-bind (pathname printed-value namestring) + test + (assert-equal printed-value (output pathname)) + (assert-equal namestring (namestring pathname)))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5d4b0622357a2b6ac96dad2... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5d4b0622357a2b6ac96dad2... You're receiving this email because of your account on gitlab.common-lisp.net.