Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

2 changed files:

Changes:

  • src/code/pathname.lisp
    ... ... @@ -121,58 +121,73 @@
    121 121 
     (defun %print-pathname (pathname stream depth)
    122 122 
       (declare (ignore depth))
    123 123 
       (let* ((host (%pathname-host pathname))
    124 
    +	 (device (%pathname-device pathname))
    125 
    +	 (directory (%pathname-directory pathname))
    126 
    +	 (name (%pathname-name pathname))
    127 
    +	 (type (%pathname-type pathname))
    128 
    +	 (version (%pathname-version pathname))
    129 
    +	 (unspecific-p (or (eq device :unspecific)
    130 
    +			   (eq name :unspecific)
    131 
    +			   (eq type :unspecific)
    132 
    +			   (eq version :unspecific)))
    124 133 
     	 (namestring (if host
    125 134 
     			 (handler-case (namestring pathname)
    126 135 
     			   (error nil))
    127 136 
     			 nil)))
    128 
    -    (cond (namestring
    137 
    +    ;; A pathname with :UNSPECIFIC components has a namestring that
    138 
    +    ;; ignores :UNSPECIFIC (and NIL).  Thus the namestring exists, but
    139 
    +    ;; we want to use our special syntax to print the pathname
    140 
    +    ;; readably when :UNSPECIFIC occurs.
    141 
    +    (cond ((and namestring (not unspecific-p))
    129 142 
     	   (if (or *print-escape* *print-readably*)
    130 143 
     	       (format stream "#P~S" namestring)
    131 144 
     	       (format stream "~A" namestring)))
    132 145 
     	  (t
    133 
    -	   (let ((device (%pathname-device pathname))
    134 
    -		 (directory (%pathname-directory pathname))
    135 
    -		 (name (%pathname-name pathname))
    136 
    -		 (type (%pathname-type pathname))
    137 
    -		 (version (%pathname-version pathname)))
    138 
    -	     (cond ((every #'(lambda (d)
    139 
    -			       (or (stringp d)
    140 
    -				   (symbolp d)))
    141 
    -			   (cdr directory))
    142 
    -		    ;; A CMUCL extension.  If we have an unprintable
    143 
    -		    ;; pathname, convert it to a form that would be
    144 
    -		    ;; suitable as args to MAKE-PATHNAME to recreate
    145 
    -		    ;; the pathname.
    146 
    -		    ;;
    147 
    -		    ;; We don't handle search-lists because we don't
    148 
    -		    ;; currently have a readable syntax for
    149 
    -		    ;; search-lists.
    150 
    -		    (collect ((result))
    151 
    -		      (unless (eq host *unix-host*)
    152 
    -			(result :host)
    153 
    -			(result (if host
    154 
    -				    (pathname-host pathname)
    155 
    -				    nil)))
    156 
    -		      (when device
    157 
    -			(result :device)
    158 
    -			(result device))
    159 
    -		      (when directory
    160 
    -			(result :directory)
    161 
    -			(result directory))
    162 
    -		      (when name
    163 
    -			(result :name)
    164 
    -			(result name))
    165 
    -		      (when type
    166 
    -			(result :type)
    167 
    -			(result type))
    168 
    -		      (when version
    169 
    -			(result :version)
    170 
    -			(result version))
    171 
    -		      (format stream "#P~S" (result))))
    172 
    -		   (*print-readably*
    173 
    -		    (error 'print-not-readable :object pathname))
    174 
    -		   (t
    175 
    -		    (funcall (formatter "#<Unprintable pathname,~:_ Host=~S,~:_ Device=~S,~:_ ~
    146 
    +	   (cond ((and
    147 
    +		   ;; We only use the extension if the pathname does
    148 
    +		   ;; not contain a pattern object which doesn't print
    149 
    +		   ;; readably.  Search-lists, which are part of the
    150 
    +		   ;; directory component, are excluded too.
    151 
    +		   (not (typep name 'pattern))
    152 
    +		   (not (typep type 'pattern))
    153 
    +		   (every #'(lambda (d)
    154 
    +			      (or (stringp d)
    155 
    +				  (symbolp d)))
    156 
    +			  (cdr directory)))
    157 
    +		  ;; A CMUCL extension.  If we have an unprintable
    158 
    +		  ;; pathname, convert it to a form that would be
    159 
    +		  ;; suitable as args to MAKE-PATHNAME to recreate
    160 
    +		  ;; the pathname.
    161 
    +		  ;;
    162 
    +		  ;; We don't handle search-lists because we don't
    163 
    +		  ;; currently have a readable syntax for
    164 
    +		  ;; search-lists.
    165 
    +		  (collect ((result))
    166 
    +		    (unless (eq host *unix-host*)
    167 
    +		      (result :host)
    168 
    +		      (result (if host
    169 
    +				  (pathname-host pathname)
    170 
    +				  nil)))
    171 
    +		    (when device
    172 
    +		      (result :device)
    173 
    +		      (result device))
    174 
    +		    (when directory
    175 
    +		      (result :directory)
    176 
    +		      (result directory))
    177 
    +		    (when name
    178 
    +		      (result :name)
    179 
    +		      (result name))
    180 
    +		    (when type
    181 
    +		      (result :type)
    182 
    +		      (result type))
    183 
    +		    (when version
    184 
    +		      (result :version)
    185 
    +		      (result version))
    186 
    +		    (format stream "#P~S" (result))))
    187 
    +		 (*print-readably*
    188 
    +		  (error 'print-not-readable :object pathname))
    189 
    +		 (t
    190 
    +		  (funcall (formatter "#<Unprintable pathname,~:_ Host=~S,~:_ Device=~S,~:_ ~
    176 191 
     				Directory=~S,~:_ Name=~S,~:_ Type=~S,~:_ Version=~S>")
    177 192 
     			     stream
    178 193 
     			     (%pathname-host pathname)

  • tests/pathname.lisp
    ... ... @@ -83,3 +83,31 @@
    83 83 
     	  and type = (pathname-type f)
    84 84 
     	  do
    85 85 
     	     (assert-true (and (null name) (null type)) f))))
    86 
    +
    87 
    +
    88 
    +
    89 
    +;; Test that pathnames with :unspecific components are printed using
    90 
    +;; our extension to make :unspecific explicit.
    91 
    +(define-test issue.171.unspecific
    92 
    +  (:tag :issues)
    93 
    +  (flet ((output (path)
    94 
    +	   (with-output-to-string (s)
    95 
    +	     (write path :stream s))))
    96 
    +    (dolist (test
    97 
    +	     (list
    98 
    +	      (list (make-pathname :name "foo" :type :unspecific)
    99 
    +		    "#P(:NAME \"foo\" :TYPE :UNSPECIFIC)"
    100 
    +		    "foo")
    101 
    +	      (list (make-pathname :name :unspecific :type "foo")
    102 
    +		    "#P(:NAME :UNSPECIFIC :TYPE \"foo\")"
    103 
    +		    ".foo")
    104 
    +	      (list (make-pathname :name "foo" :type "txt" :version :unspecific)
    105 
    +		    "#P(:NAME \"foo\" :TYPE \"txt\" :VERSION :UNSPECIFIC)"
    106 
    +		    "foo.txt")
    107 
    +	      (list (make-pathname :device :unspecific)
    108 
    +		    "#P(:DEVICE :UNSPECIFIC)"
    109 
    +		    "")))
    110 
    +      (destructuring-bind (pathname printed-value namestring)
    111 
    +	  test
    112 
    +	(assert-equal printed-value (output pathname))
    113 
    +	(assert-equal namestring (namestring pathname))))))

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help