X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpathnames.impure.lisp;h=5e9a8b8a21e7cef44b125b9893085fc29f0760a9;hb=f2db6743b1fadeea9e72cb583d857851c87efcd4;hp=845d70fd05c16e2d2cc8f4b60d4a5d226e3dcd1b;hpb=8886298f2c0e50e595cf481c426b6331ab898a23;p=sbcl.git

diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 845d70f..5e9a8b8 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -20,12 +20,11 @@
 (setf (logical-pathname-translations "demo0")
       '(("**;*.*.*" "/tmp/")))
 
-;;; In case of a parse error we want to get a condition of type
-;;; CL:PARSE-ERROR (or more specifically, of type
-;;; SB-KERNEL:NAMESTRING-PARSE-ERROR).
+;;; In case of a parse error we want to get a condition of type TYPE-ERROR,
+;;; because ANSI says so. (This used to be PARSE-ERROR.)
 (assert
   (typep (grab-condition (logical-pathname "demo0::bla;file.lisp"))
-         'parse-error))
+         'type-error))
 
 ;;; some things SBCL-0.6.9 used not to parse correctly:
 ;;;
@@ -408,4 +407,74 @@
                (let ((*default-pathname-defaults* #p"quux/"))
                  (compile-file-pathname "bar.lisp"))))
 
+(enough-namestring #p".a*")
+
+
+(assert (eq 99
+            (pathname-version
+             (translate-pathname
+              (make-pathname :name "foo" :type "bar" :version 99)
+              (make-pathname :name :wild :type :wild :version :wild)
+              (make-pathname :name :wild :type :wild :version :wild)))))
+
+(assert (eq 99
+            (pathname-version
+             (translate-pathname
+              (make-pathname :name "foo" :type "bar" :version 99)
+              (make-pathname :name :wild :type :wild :version :wild)
+              (make-pathname :name :wild :type :wild :version nil)))))
+
+;;; enough-namestring relative to root
+(assert (equal "foo" (enough-namestring "/foo" "/")))
+
+;;; Check the handling of NIL, :UNSPECIFIC, the empty string, and
+;;; non-NIL strings in NATIVE-NAMESTRING implementations.  Revised by
+;;; RMK 2007-11-28, attempting to preserve the apparent intended
+;;; denotation of SBCL's then-current pathname implementation.
+(assert (equal
+         (loop with components = (list nil :unspecific "" "a")
+               for name in components
+               appending (loop for type in components
+                               as pathname = (make-pathname
+                                              #+win32 "C"
+                                              :directory '(:absolute "tmp")
+                                              :name name :type type)
+                               collect (ignore-errors
+                                         (sb-ext:native-namestring pathname))))
+         #-win32
+            #|type  NIL       :UNSPECIFIC   ""        "a"         |#
+#|name       |#
+#|NIL        |#   '("/tmp/"   "/tmp/"       NIL       NIL
+#|:UNSPECIFIC|#     "/tmp/"   "/tmp/"       NIL       NIL
+#|""         |#     "/tmp/"   "/tmp/"       "/tmp/."  "/tmp/.a"
+#|"a"        |#     "/tmp/a"  "/tmp/a"      "/tmp/a." "/tmp/a.a")
+
+         #+win32
+            #|type  NIL           :UNSPECIFIC   ""            "a"     |#
+#|name       |#
+#|NIL        |#   '("C:\\tmp\\"   "C:\\tmp\\"   NIL           NIL
+#|:UNSPECIFIC|#     "C:\\tmp\\"   "C:\\tmp\\"   NIL           NIL
+#|""         |#     "C:\\tmp\\"   "C:\\tmp\\"   "C:\\tmp\\."  "C:\\tmp\\.a"
+#|"a"        |#     "C:\\tmp\\a"  "C:\\tmp\\a"  "C:\\tmp\\a." "C:\\tmp\\a.a")))
+
+(with-test (:name :delete-file-logical-pathname)
+  (setf (logical-pathname-translations "SB-TEST")
+        (list (list "**;*.*.*" (make-pathname :name :wild
+                                              :type :wild
+                                              :defaults (truename ".")))))
+  (let ((test (pathname "SB-TEST:delete-logical-pathname.tmp")))
+    (assert (typep test 'logical-pathname))
+    (with-open-file (f test :direction :output)
+      (write-line "delete me!" f))
+    (assert (probe-file test))
+    (assert (delete-file test))
+    (assert (not (probe-file test)))))
+
+(with-test (:name :logical-pathname-type-error)
+  (assert (eq :type-error-ok
+              (handler-case (logical-pathname "FOO.txt")
+                (type-error () :type-error-ok))))
+  (assert (eq :type-error-ok
+              (handler-case (logical-pathname "SYS:%")
+                (type-error () :type-error-ok)))))
 ;;;; success