X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpathnames.impure.lisp;h=b9a416e3f25880919b0e5225230f30ea3a33f355;hb=457d80803848ccd73b28508177f1888ff66bc72f;hp=7898a294a8cfd1f1f8246ccffb4f9277fb72d5bd;hpb=d86eaf5880e4f8738e20a739334ef380ec98762a;p=sbcl.git

diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 7898a29..b9a416e 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -14,9 +14,8 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
-(in-package "CL-USER")
-
 (load "assertoid.lisp")
+(use-package "ASSERTOID")
 
 (setf (logical-pathname-translations "demo0")
       '(("**;*.*.*" "/tmp/")))
@@ -25,7 +24,7 @@
 ;;; CL:PARSE-ERROR (or more specifically, of type
 ;;; SB-KERNEL:NAMESTRING-PARSE-ERROR).
 (assert
-  (typep (grab-condition (translate-logical-pathname "demo0::bla;file.lisp"))
+  (typep (grab-condition (logical-pathname "demo0::bla;file.lisp"))
          'parse-error))
 
 ;;; some things SBCL-0.6.9 used not to parse correctly:
@@ -64,7 +63,7 @@
 ;;; compelling reason for the implementors to choose case
 ;;; insensitivity and a canonical case.)
 (setf (logical-pathname-translations "FOO") 
-      '(("**;*.*.*" "/full/path/to/foo/**/*.*.*")))
+      '(("**;*.*.*" "/full/path/to/foo/**/*.*")))
 (let* ((pn1 (make-pathname :host "FOO" :directory "etc" :name "INETD" 
                            :type "conf"))
        (pn2 (make-pathname :host "foo" :directory "ETC" :name "inetd" 
@@ -79,17 +78,21 @@
 ;;; FIXME: currently SBCL throws NAMESTRING-PARSE-ERROR: should this be
 ;;; a TYPE-ERROR?
 
-(assert (not (ignore-errors
-               (make-pathname :host "FOO" :directory "!bla" :name "bar"))))
-
-;; error: name-component not valid
-(assert (not (ignore-errors
-               (make-pathname :host "FOO" :directory "bla" :name "!bar"))))
-
-;; error: type-component not valid.
-(assert (not (ignore-errors
-               (make-pathname :host "FOO" :directory "bla" :name "bar"
-                              :type "&baz"))))
+(locally
+  ;; MAKE-PATHNAME is UNSAFELY-FLUSHABLE
+  (declare (optimize safety))
+  
+  (assert (not (ignore-errors
+		(make-pathname :host "FOO" :directory "!bla" :name "bar"))))
+  
+  ;; error: name-component not valid
+  (assert (not (ignore-errors
+		(make-pathname :host "FOO" :directory "bla" :name "!bar"))))
+  
+  ;; error: type-component not valid.
+  (assert (not (ignore-errors
+		(make-pathname :host "FOO" :directory "bla" :name "bar"
+			       :type "&baz")))))
 
 ;;; We may need to parse the host as a LOGICAL-NAMESTRING HOST. The
 ;;; HOST in PARSE-NAMESTRING can be either a string or :UNSPECIFIC
@@ -261,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=
@@ -275,6 +283,12 @@
 	 (setf (logical-pathname-translations "")
 	       (list '("**;*.*.*" "/**/*.*")))))
 
+;;; Bug 200: translate-logical-pathname is according to the spec supposed
+;;; not to give errors if asked to translate a namestring for a valid
+;;; physical pathname.  Failed in 0.7.7.28 and before
+(assert (string= (namestring (translate-logical-pathname "/")) "/"))
+
+
 ;;; Not strictly pathname logic testing, but until sbcl-0.7.6.19 we
 ;;; had difficulty with non-FILE-STREAM stream arguments to pathname
 ;;; functions (they would cause memory protection errors).  Make sure
@@ -284,5 +298,43 @@
 (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)
+    (print p)
+    (handler-case
+	(let ((*print-readably* t))
+	  (assert (equal (read-from-string (format nil "~S" p)) p)))
+      (print-not-readable () nil))))
+
+;;; BUG 330: "PARSE-NAMESTRING should accept namestrings as the default argument"
+;;; ...and streams as well
+(assert (equal (parse-namestring "foo" nil "/")
+	       (parse-namestring "foo" nil #P"/")))
+(let ((test "parse-namestring-test.tmp"))
+  (unwind-protect
+       (with-open-file (f test :direction :output)
+	 ;; FIXME: This test is a bit flaky, since we only check that
+	 ;; no error is signalled. The dilemma here is "what is the
+	 ;; correct result when defaults is a _file_, not a
+	 ;; directory". Currently (0.8.10.73) we get #P"foo" here (as
+	 ;; opposed to eg. #P"/path/to/current/foo"), which is
+	 ;; possibly mildly surprising but probably conformant.
+	 (assert (parse-namestring "foo" nil f)))
+    (when (probe-file test)
+      (delete-file test))))
+
+;;; ENOUGH-NAMESTRING should probably not fail when the namestring in
+;;; question has a :RELATIVE pathname.
+(assert (equal (enough-namestring #p"foo" #p"./") "foo"))
+
 ;;;; success
 (quit :unix-status 104)