X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpathnames.impure.lisp;h=e2c200e8a09c20781caa70ab533efffed65d78fc;hb=0a15b6bbf9d5d3a64b5ac08bb96b6e5ec221d2ae;hp=a46c6e0d225cb6d72fc01ca3c0218378d8b48f38;hpb=c49d74c70beef5fb0c8774a571b7c074aba9b851;p=sbcl.git

diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index a46c6e0..e2c200e 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:
 ;;;
@@ -457,4 +456,66 @@
 #|: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)))))
+
+;;; Reported by Willem Broekema: Reading #p"\\\\" caused an error due
+;;; to insufficient sanity in input testing in EXTRACT-DEVICE (in
+;;; src;code;win32-pathname).
+#+win32
+(with-test (:name :bug-489698)
+  (assert (equal (make-pathname :directory '(:absolute))
+                 (read-from-string "#p\"\\\\\\\\\""))))
+
+(with-test (:name :load-logical-pathname-translations)
+  (let* ((cwd (truename "."))
+         (foo (merge-pathnames "llpnt-foo.translations" cwd))
+         (bar (merge-pathnames "llpnt-bar.translations" cwd))
+         (translations (logical-pathname-translations "SYS")))
+    (unwind-protect
+         (progn
+           (with-open-file (f foo :direction :output)
+             (prin1 (list (list "*.TEXT" (make-pathname
+                                          :directory '(:absolute "my" "foo")
+                                          :name :wild :type "txt")))
+                    f))
+           (with-open-file (f bar :direction :output)
+             (prin1 (list (list "*.CL" (make-pathname
+                                        :directory '(:absolute "my" "bar")
+                                        :name :wild :type "lisp"))) f))
+           (setf (logical-pathname-translations "SYS")
+                 (list* (list "SITE;LLPNT-FOO.TRANSLATIONS.NEWEST" foo)
+                        (list "SITE;LLPNT-BAR.TRANSLATIONS.NEWEST" bar)
+                        translations))
+           (assert (load-logical-pathname-translations "LLPNT-FOO"))
+           (assert (load-logical-pathname-translations "LLPNT-BAR"))
+           (assert
+            (and
+             (equal "/my/bar/quux.lisp"
+                    (namestring (translate-logical-pathname "LLPNT-BAR:QUUX.CL")))
+             (equal "/my/foo/quux.txt"
+                    (namestring (translate-logical-pathname "LLPNT-FOO:QUUX.TEXT"))))))
+      (ignore-errors (delete-file foo))
+      (ignore-errors (delete-file bar))
+      (setf (logical-pathname-translations "SYS") translations))))
+
 ;;;; success