+(load "assertoid.lisp")
+
+(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).
+(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)))
+
+;;; 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?
+
+(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
+;;; 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)))
+
+;;; turning one logical pathname into another: