0.6.12.10:

[sbcl.git] / tests / pathnames.impure.lisp

diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 7fd7e3a..d462c1b 100644 (file)
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -16,11 +16,7 @@
 
 (in-package "CL-USER")
 
-;;(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defmacro grab-condition (&body body)
-    `(nth-value 1
-      (ignore-errors ,@body)))
-;;)
+(load "assertoid.lisp")
 
 (setf (logical-pathname-translations "demo0")
       '(("**;*.*.*" "/tmp/")))
@@ -58,7 +54,7 @@
 ;;; handle the following case exactly (otherwise we get an error:
 ;;; "#'IDENTITY CALLED WITH 2 ARGS."
 (setf (logical-pathname-translations "demo2")
-        '(("test;**;*.*" "/tmp/demo2/test/")))
+        '(("test;**;*.*" "/tmp/demo2/test")))
 (enough-namestring "demo2:test;foo.lisp")
 
 ;;; When a pathname comes from a logical host, it should be in upper
@@ -77,6 +73,25 @@
   (assert (equal pn1 pn2))
   (assert (equal pn1 pn3)))
 
+;;; In addition to the upper-case constraint above, if the logical-pathname
+;;; contains a string component in e.g. the directory, name and type slot,
+;;; these should be valid "WORDS", according to CLHS 19.3.1.
+;;; FIXME: currently SBCL throws NAMESTRING-PARSE-ERROR: should this be
+;;; a TYPE-ERROR?
+
+;; error: directory-component not valid
+(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
 ;;; without actually requiring the system to signal an error (apart
@@ -95,6 +110,12 @@
 (let ((cond (grab-condition (parse-namestring "foo:jeamland" "demo2"))))
   (assert (typep cond 'type-error)))
 
+;;; turning one logical pathname into another:
+(setf (logical-pathname-translations "foo")
+       '(("tohome;*.*.*" "home:*.*.*")))
+(assert (equal (namestring (translate-logical-pathname "foo:tohome;x.y"))
+               "home:x.y"))    
+
 ;;; 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
@@ -102,13 +123,18 @@
 (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)
+;;; FIXME: A comment on this section up to sbcl-0.6.11.30 or so said
+;;;   examples from CLHS: Section 19.4, LOGICAL-PATHNAME-TRANSLATIONS
+;;;   (sometimes converted to the Un*x way of things)
+;;; but when I looked it up I didn't see the connection. Presumably
+;;; there's some code in this section which should be attributed
+;;; to something in the ANSI spec, but I don't know what code it is
+;;; or what section of the specification has the related code.
 (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"))
+                            "test0:foo;bar;baz;mum.quux"))
+               "/library/foo/foo/bar/baz/mum.quux"))
 (setf (logical-pathname-translations "prog")
         '(("RELEASED;*.*.*"        "MY-UNIX:/sys/bin/my-prog/")
           ("RELEASED;*;*.*.*"      "MY-UNIX:/sys/bin/my-prog/*/")
@@ -126,6 +152,12 @@
                             "prog:code;documentation.lisp"))
                "/lib/prog/docum.lisp"))
 
+;;; ANSI section 19.3.1.1.5 specifies that translation to a filesystem
+;;; which doesn't have versions should ignore the version slot. CMU CL
+;;; didn't ignore this as it should, but we do.
+(assert (equal (namestring (translate-logical-pathname
+                            "test0:foo;bar;baz;mum.quux.3"))
+               "/library/foo/foo/bar/baz/mum.quux"))
+
 ;;; success
 (quit :unix-status 104)
-(in-package :cl-user)