(def!method print-object ((pathname logical-pathname) stream)
(let ((namestring (handler-case (namestring pathname)
(error nil))))
- (if namestring
+ (if (and namestring (or *read-eval* (not *print-readably*)))
(format stream "#.(CL:LOGICAL-PATHNAME ~S)" namestring)
(print-unreadable-object (pathname stream :type t)
(format
stream
- "~_:HOST ~S ~_:DIRECTORY ~S ~_:FILE ~S ~_:NAME ~S ~_:VERSION ~S"
+ "~_:HOST ~S ~_:DIRECTORY ~S ~_:NAME ~S ~_:TYPE ~S ~_:VERSION ~S"
(%pathname-host pathname)
(%pathname-directory pathname)
(%pathname-name pathname)
(defun unparse-logical-piece (thing)
(etypecase thing
+ ((member :wild) "*")
(simple-string thing)
(pattern
(collect ((strings))
(t (error "invalid keyword: ~S" piece))))))
(apply #'concatenate 'simple-string (strings))))))
+(defun unparse-logical-file (pathname)
+ (declare (type pathname pathname))
+ (collect ((strings))
+ (let* ((name (%pathname-name pathname))
+ (type (%pathname-type pathname))
+ (version (%pathname-version pathname))
+ (type-supplied (not (or (null type) (eq type :unspecific))))
+ (version-supplied (not (or (null version)
+ (eq version :unspecific)))))
+ (when name
+ (when (and (null type) (position #\. name :start 1))
+ (error "too many dots in the name: ~S" pathname))
+ (strings (unparse-logical-piece name)))
+ (when type-supplied
+ (unless name
+ (error "cannot specify the type without a file: ~S" pathname))
+ (when (typep type 'simple-base-string)
+ (when (position #\. type)
+ (error "type component can't have a #\. inside: ~S" pathname)))
+ (strings ".")
+ (strings (unparse-logical-piece type)))
+ (when version-supplied
+ (unless type-supplied
+ (error "cannot specify the version without a type: ~S" pathname))
+ (etypecase version
+ ((member :newest) (strings ".NEWEST"))
+ ((member :wild) (strings ".*"))
+ (fixnum (strings ".") (strings (format nil "~D" version))))))
+ (apply #'concatenate 'simple-string (strings))))
+
;;; Unparse a logical pathname string.
(defun unparse-enough-namestring (pathname defaults)
(let* ((path-directory (pathname-directory pathname))
(concatenate 'simple-string
(logical-host-name (%pathname-host pathname)) ":"
(unparse-logical-directory pathname)
- (unparse-unix-file pathname)))
+ (unparse-logical-file pathname)))
\f
;;;; logical pathname translations