Commit ffd0723a authored by Christophe Rhodes's avatar Christophe Rhodes
Browse files

0.8.7.24: 

	More pathname fun, *sigh*
	... make logical pathnames respect print/read consistency (version
		*is* significant for them)
	... adjust the pathname tests so that they test equality rather
		than namestring equality, but minus version testing
		because that's too complicated right now.
parent c44f2e69

src/code/pathname.lisp

+1 −1
Original line number Diff line number Diff line
@@ -37,7 +37,7 @@ 
			(lambda (x)

			  (logical-host-name (%pathname-host x))))

		       (unparse-directory #'unparse-logical-directory)

		       (unparse-file #'unparse-unix-file)

		       (unparse-file #'unparse-logical-file)

		       (unparse-enough #'unparse-enough-namestring)

		       (customary-case :upper)))

  (name "" :type simple-base-string)

src/code/target-pathname.lisp

+31 −1
Original line number Diff line number Diff line
@@ -1413,6 +1413,36 @@ a host-structure or string." 
		  (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))
@@ -1449,7 +1479,7 @@ a host-structure or string." 
  (concatenate 'simple-string

	       (logical-host-name (%pathname-host pathname)) ":"

	       (unparse-logical-directory pathname)

	       (unparse-unix-file pathname)))

	       (unparse-logical-file pathname)))



;;;; logical pathname translations

tests/pathnames.impure.lisp

+23 −2
Original line number Diff line number Diff line
@@ -264,8 +264,13 @@ 


        ;; FIXME: test version handling in LPNs

        )

      do (assert (string= (namestring (apply #'merge-pathnames params))

                          (namestring expected-result))))

      do (let ((result (apply #'merge-pathnames params)))

	   (macrolet ((frob (op)

			`(assert (equal (,op result) (,op expected-result)))))

	     (frob pathname-host)

	     (frob pathname-directory)

	     (frob pathname-name)

	     (frob pathname-type))))



;;; host-namestring testing

(assert (string=
@@ -293,5 +298,21 @@ 
(assert (raises-error? (merge-pathnames (make-string-output-stream))

		       type-error))



;;; ensure read/print consistency (or print-not-readable-error) on

;;; pathnames:

(let ((pathnames (list

		  (make-pathname :name "foo" :type "txt" :version :newest)

		  (make-pathname :name "foo" :type "txt" :version 1)

		  (make-pathname :name "foo" :type ".txt")

		  (make-pathname :name "foo." :type "txt")

		  (parse-namestring "SCRATCH:FOO.TXT.1")

		  (parse-namestring "SCRATCH:FOO.TXT.NEWEST")

		  (parse-namestring "SCRATCH:FOO.TXT"))))

  (dolist (p pathnames)

    (handler-case

	(let ((*print-readably* t))

	  (assert (equal (read-from-string (format nil "~S" p)) p)))

      (print-not-readable () nil))))



;;;; success

(quit :unix-status 104)

version.lisp-expr

+1 −1
Original line number Diff line number Diff line
@@ -17,4 +17,4 @@ 
;;; checkins which aren't released. (And occasionally for internal

;;; versions, especially for internal versions off the main CVS

;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)

"0.8.7.23"
 
"0.8.7.24"