X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpathnames.impure.lisp;h=4afbba068fe602d06f40b2f16e2525202ed61ce0;hb=4fc9d21ae1d8a6a2f8ff70f589d5da103203de13;hp=949e5b7605eae5a9edacb58da45591f0b9c2492c;hpb=8eb659eee63e989f2f3da5673c3ac00a6712f567;p=sbcl.git

diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 949e5b7..4afbba0 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -16,17 +16,113 @@
 
 (in-package "CL-USER")
 
-(setf (logical-pathname-translations "foo")
-      '(("REL;*.*.*"       "/tmp/")
-	("MAIL;**;*.MAIL"  "/tmp/subdir/")
-	("PROGGIES;*"      "/tmp/")))
+(defmacro grab-condition (&body body)
+  `(nth-value 1
+     (ignore-errors ,@body)))
 
-(assert (string= (format nil
-			 "~S"
-			 (translate-logical-pathname "foo:proggies;save"))
-		 "#P\"/tmp/save\""))
+(setf (logical-pathname-translations "demo0")
+      '(("**;*.*.*" "/tmp/")))
 
-(compile-file-pathname "foo:proggies;save")
+;;; 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).
+(assert
+  (typep (grab-condition (translate-logical-pathname "demo0::bla;file.lisp"))
+         'parse-error))
+
+;;; some things SBCL-0.6.9 used not to parse correctly:
+;;;
+;;; SBCL used to throw an error saying there's no translation.
+(assert (equal (namestring (translate-logical-pathname "demo0:file.lisp"))
+               "/tmp/file.lisp"))
+;;; We do not match a null directory to every wild path:
+(assert (not (pathname-match-p "demo0:file.lisp"
+                               (logical-pathname "demo0:tmp;**;*.*.*"))))
+;;; Remove "**" from our resulting pathname when the source-dir is NIL:
+(setf (logical-pathname-translations "demo1")
+      '(("**;*.*.*" "/tmp/**/*.*") (";**;*.*.*" "/tmp/rel/**/*.*")))
+(assert (not (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
+                    "/tmp/**/foo.lisp")))
+;;; That should be correct:
+(assert (equal (namestring (translate-logical-pathname "demo1:foo.lisp"))
+               "/tmp/foo.lisp"))
+;;; Check for absolute/relative path confusion:
+(assert (not (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
+                     "tmp/rel/foo.lisp")))
+(assert (equal (namestring (translate-logical-pathname "demo1:;foo.lisp"))
+               "/tmp/rel/foo.lisp"))
+                     
+;;; Under SBCL: new function #'UNPARSE-ENOUGH-NAMESTRING, to
+;;; handle the following case exactly (otherwise we get an error:
+;;; "#'IDENTITY CALLED WITH 2 ARGS."
+(setf (logical-pathname-translations "demo2")
+        '(("test;**;*.*" "/tmp/demo2/test")))
+(enough-namestring "demo2:test;foo.lisp")
+
+;;; When a pathname comes from a logical host, it should be in upper
+;;; case. (This doesn't seem to be specifically required in the ANSI
+;;; spec, but it's left up to the implementors, and the arguments made
+;;; in the cleanup issue PATHNAME-LOGICAL:ADD seem to be a pretty
+;;; compelling reason for the implementors to choose case
+;;; insensitivity and a canonical case.)
+(setf (logical-pathname-translations "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" 
+                           :type "CONF"))
+       (pn3 (read-from-string (prin1-to-string pn1))))
+  (assert (equal pn1 pn2))
+  (assert (equal pn1 pn3)))
+
+;;; We may need to parse the host as a LOGICAL-NAMESTRING HOST. The
+;;; HOST in PARSE-NAMESTRING can be either a string or :UNSPECIFIC
+;;; without actually requiring the system to signal an error (apart
+;;; from host mismatches).
+(assert (equal (namestring (parse-namestring "" "FOO")) "FOO:"))
+(assert (equal (namestring (parse-namestring "" :unspecific)) ""))
+
+;;; The third would work if the call were (and it should continue to
+;;; work ...)
+(parse-namestring ""
+                  (pathname-host
+                   (translate-logical-pathname
+                    "FOO:")))
+
+;;; ANSI says PARSE-NAMESTRING returns TYPE-ERROR on host mismatch.
+(let ((cond (grab-condition (parse-namestring "foo:jeamland" "demo2"))))
+  (assert (typep cond 'type-error)))
+
+;;; ANSI, in its wisdom, specifies that it's an error (specifically a
+;;; TYPE-ERROR) to query the system about the translations of a string
+;;; which doesn't have any translations. It's not clear why we don't
+;;; just return NIL in that case, but they make the rules..
+(let ((cond (grab-condition (logical-pathname-translations "unregistered-host"))))
+  (assert (typep cond 'type-error)))
+
+;;; examples from CLHS: Section 19.4, Logical Pathname Translations
+;;; (sometimes converted to the Un*x way of things)
+(setf (logical-pathname-translations "test0")
+        '(("**;*.*.*"              "/library/foo/**/")))
+(assert (equal (namestring (translate-logical-pathname
+                            "test0:foo;bar;baz;mum.quux.3"))
+               "/library/foo/foo/bar/baz/mum.quux.3"))
+(setf (logical-pathname-translations "prog")
+        '(("RELEASED;*.*.*"        "MY-UNIX:/sys/bin/my-prog/")
+          ("RELEASED;*;*.*.*"      "MY-UNIX:/sys/bin/my-prog/*/")
+          ("EXPERIMENTAL;*.*.*"    "MY-UNIX:/usr/Joe/development/prog/")
+          ("EXPERIMENTAL;*;*.*.*"  "MY-UNIX:/usr/Joe/development/prog/*/")))
+(setf (logical-pathname-translations "prog")
+        '(("CODE;*.*.*"             "/lib/prog/")))
+(assert (equal (namestring (translate-logical-pathname
+                            "prog:code;documentation.lisp"))
+               "/lib/prog/documentation.lisp"))
+(setf (logical-pathname-translations "prog")
+        '(("CODE;DOCUMENTATION.*.*" "/lib/prog/docum.*")
+          ("CODE;*.*.*"             "/lib/prog/")))
+(assert (equal (namestring (translate-logical-pathname
+                            "prog:code;documentation.lisp"))
+               "/lib/prog/docum.lisp"))
 
 ;;; success
 (quit :unix-status 104)