Skip to content
Snippets Groups Projects
Commit bdd7294f authored by Raymond Toy's avatar Raymond Toy
Browse files

Fix #171: Readably print pathnames with :unspecific

parent 5d4b0622
Branches
Tags
1 merge request!134Fix #171: Readably print pathnames with :unspecific
......@@ -121,24 +121,39 @@
(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)
(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))
(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
......
......@@ -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))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please to comment