X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpathnames.impure.lisp;h=c81cb5a221e4eaa02c1c9c8ec017148a93b0f58f;hb=35f870eecfcaaba496d54e0f290b09e63884f74c;hp=a58c08eb0fd99e7b92dee070c100f96c8c63b04c;hpb=e73a30c901ab234291aefc9f1e73507650628892;p=sbcl.git diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index a58c08e..c81cb5a 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -9,7 +9,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -48,7 +48,7 @@ "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." @@ -62,11 +62,11 @@ ;;; 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") +(setf (logical-pathname-translations "FOO") '(("**;*.*.*" "/full/path/to/foo/**/*.*"))) -(let* ((pn1 (make-pathname :host "FOO" :directory "etc" :name "INETD" +(let* ((pn1 (make-pathname :host "FOO" :directory "etc" :name "INETD" :type "conf")) - (pn2 (make-pathname :host "foo" :directory "ETC" :name "inetd" + (pn2 (make-pathname :host "foo" :directory "ETC" :name "inetd" :type "CONF")) (pn3 (read-from-string (prin1-to-string pn1)))) (assert (equal pn1 pn2)) @@ -81,18 +81,18 @@ (locally ;; MAKE-PATHNAME is UNSAFELY-FLUSHABLE (declare (optimize safety)) - + (assert (not (ignore-errors - (make-pathname :host "FOO" :directory "!bla" :name "bar")))) - + (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")))) - + (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"))))) + (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 @@ -225,14 +225,14 @@ ;; recognizes a logical pathname namestring when ;; default-pathname is a logical pathname ;; FIXME: 0.6.12.23 fails this one. - ;; - ;; And, as it happens, it's right to fail it. Because - ;; #p"name1" is read in with the ambient *d-p-d* value, which - ;; has a physical (Unix) host; therefore, the host of the - ;; default-pathname argument to merge-pathnames is - ;; irrelevant. The result is (correctly) different if - ;; '#p"name1"' is replaced by "name1", below, though it's - ;; still not what one might expect... -- CSR, 2002-05-09 + ;; + ;; And, as it happens, it's right to fail it. Because + ;; #p"name1" is read in with the ambient *d-p-d* value, which + ;; has a physical (Unix) host; therefore, the host of the + ;; default-pathname argument to merge-pathnames is + ;; irrelevant. The result is (correctly) different if + ;; '#p"name1"' is replaced by "name1", below, though it's + ;; still not what one might expect... -- CSR, 2002-05-09 #+nil (#P"scratch:foo;name1" #p"name1" #p"scratch:foo;") ;; or when the namestring begins with the name of a defined ;; logical host followed by a colon [I assume that refers to pathname @@ -241,23 +241,23 @@ ;; conduct the previous set of tests again, with a lpn first argument (#P"SCRATCH:USR;LOCAL;DOC;FOO" #p"scratch:;foo" #p"/usr/local/doc/") (#p"SCRATCH:SUPPLIED-DIR;NAME.TYPE" - #p"scratch:supplied-dir;" - #p"/dir/name.type") + #p"scratch:supplied-dir;" + #p"/dir/name.type") (#p"SCRATCH:DIR;SUPPLIED-NAME.TYPE" - #p"scratch:;supplied-name" - #p"/dir/name.type") + #p"scratch:;supplied-name" + #p"/dir/name.type") (#p"SCRATCH:DIR;NAME.SUPPLIED-TYPE" ,(make-pathname :host "scratch" :type "supplied-type") - #p"/dir/name.type") + #p"/dir/name.type") (#p"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR" ,(make-pathname :host "scratch" - :directory '(:relative "foo") - :name "bar") + :directory '(:relative "foo") + :name "bar") #p"/aaa/bbb/ccc/ddd/eee") (#p"SCRATCH:AAA;BBB;CCC;FOO;BAR" ,(make-pathname :host "scratch" - :directory '(:relative :back "foo") - :name "bar") + :directory '(:relative :back "foo") + :name "bar") #p"/aaa/bbb/ccc/ddd/eee") (#p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE" #p"scratch:absolute;path;name" #p"/dir/default-name.type") @@ -265,23 +265,23 @@ ;; FIXME: test version handling in LPNs ) do (let ((result (apply #'merge-pathnames params))) - (macrolet ((frob (op) - `(assert (equal (,op result) (,op expected-result))))) - (frob pathname-host) - (frob pathname-directory) - (frob pathname-name) - (frob pathname-type)))) + (macrolet ((frob (op) + `(assert (equal (,op result) (,op expected-result))))) + (frob pathname-host) + (frob pathname-directory) + (frob pathname-name) + (frob pathname-type)))) ;;; host-namestring testing (assert (string= - (namestring (parse-namestring "/foo" (host-namestring #p"/bar"))) - "/foo")) + (namestring (parse-namestring "/foo" (host-namestring #p"/bar"))) + "/foo")) (assert (string= - (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR"))) - "SCRATCH:FOO")) + (namestring (parse-namestring "FOO" (host-namestring #p"SCRATCH:BAR"))) + "SCRATCH:FOO")) (assert (raises-error? - (setf (logical-pathname-translations "") - (list '("**;*.*.*" "/**/*.*"))))) + (setf (logical-pathname-translations "") + (list '("**;*.*.*" "/**/*.*"))))) ;;; Bug 200: translate-logical-pathname is according to the spec supposed ;;; not to give errors if asked to translate a namestring for a valid @@ -294,42 +294,138 @@ ;;; functions (they would cause memory protection errors). Make sure ;;; that those errors are gone: (assert (raises-error? (pathname (make-string-input-stream "FOO")) - type-error)) + type-error)) (assert (raises-error? (merge-pathnames (make-string-output-stream)) - type-error)) + type-error)) ;;; ensure read/print consistency (or print-not-readable-error) on ;;; pathnames: (let ((pathnames (list - (make-pathname :name "foo" :type "txt" :version :newest) - (make-pathname :name "foo" :type "txt" :version 1) - (make-pathname :name "foo" :type ".txt") - (make-pathname :name "foo." :type "txt") - (parse-namestring "SCRATCH:FOO.TXT.1") - (parse-namestring "SCRATCH:FOO.TXT.NEWEST") - (parse-namestring "SCRATCH:FOO.TXT")))) + (make-pathname :name "foo" :type "txt" :version :newest) + (make-pathname :name "foo" :type "txt" :version 1) + (make-pathname :name "foo" :type ".txt") + (make-pathname :name "foo." :type "txt") + (parse-namestring "SCRATCH:FOO.TXT.1") + (parse-namestring "SCRATCH:FOO.TXT.NEWEST") + (parse-namestring "SCRATCH:FOO.TXT")))) (dolist (p pathnames) + (print p) (handler-case - (let ((*print-readably* t)) - (assert (equal (read-from-string (format nil "~S" p)) p))) + (let ((*print-readably* t)) + (assert (equal (read-from-string (format nil "~S" p)) p))) (print-not-readable () nil)))) -;;; BUG 330: "PARSE-NAMESTRING should accept namestrings as the default argument" -;;; ...and streams as well +;;; BUG 330: "PARSE-NAMESTRING should accept namestrings as the +;;; default argument" ...and streams as well (assert (equal (parse-namestring "foo" nil "/") - (parse-namestring "foo" nil #P"/"))) + (parse-namestring "foo" nil #P"/"))) (let ((test "parse-namestring-test.tmp")) (unwind-protect (with-open-file (f test :direction :output) - ;; FIXME: This test is a bit flaky, since we only check that - ;; no error is signalled. The dilemma here is "what is the - ;; correct result when defaults is a _file_, not a - ;; directory". Currently (0.8.10.73) we get #P"foo" here (as - ;; opposed to eg. #P"/path/to/current/foo"), which is - ;; possibly mildly surprising but probably conformant. - (assert (parse-namestring "foo" nil f))) + ;; FIXME: This test is a bit flaky, since we only check that + ;; no error is signalled. The dilemma here is "what is the + ;; correct result when defaults is a _file_, not a + ;; directory". Currently (0.8.10.73) we get #P"foo" here (as + ;; opposed to eg. #P"/path/to/current/foo"), which is + ;; possibly mildly surprising but probably conformant. + (assert (parse-namestring "foo" nil f))) (when (probe-file test) (delete-file test)))) +;;; ENOUGH-NAMESTRING should probably not fail when the namestring in +;;; question has a :RELATIVE pathname. +(assert (equal (enough-namestring #p"foo" #p"./") "foo")) + +;;; bug reported by Artem V. Andreev: :WILD not handled in unparsing +;;; directory lists. +(assert (equal (namestring #p"/tmp/*/") "/tmp/*/")) + +;;; Printing of pathnames; see CLHS 22.1.3.1. This section was started +;;; to confirm that pathnames are printed as their namestrings under +;;; :escape nil :readably nil. +(loop for (pathname expected . vars) in + `((#p"/foo" "#P\"/foo\"") + (#p"/foo" "#P\"/foo\"" :readably nil) + (#p"/foo" "#P\"/foo\"" :escape nil) + (#p"/foo" "/foo" :readably nil :escape nil)) + for actual = (with-standard-io-syntax + (apply #'write-to-string pathname vars)) + do (assert (string= expected actual) + () + "~S should be ~S, was ~S" + (list* 'write-to-string pathname vars) + expected + actual)) + +;;; we got (truename "/") wrong for about 6 months. Check that it's +;;; still right. +(let ((pathname (truename "/"))) + (assert (equalp pathname #p"/")) + (assert (equal (pathname-directory pathname) '(:absolute)))) + +;;; we failed to unparse logical pathnames with :NAME :WILD :TYPE NIL. +;;; (Reported by Pascal Bourguignon. +(let ((pathname (make-pathname :host "SYS" :directory '(:absolute :wild-inferiors) + :name :wild :type nil))) + (assert (string= (namestring pathname) "SYS:**;*")) + (assert (string= (write-to-string pathname :readably t) "#P\"SYS:**;*\""))) + +;;; reported by James Y Knight on sbcl-devel 2006-05-17 +(let ((p1 (make-pathname :directory '(:relative "bar"))) + (p2 (make-pathname :directory '(:relative :back "foo")))) + (assert (equal (merge-pathnames p1 p2) + (make-pathname :directory '(:relative :back "foo" "bar"))))) + +;;; construct native namestrings even if the directory is empty (means +;;; that same as if (:relative)) +(assert (equal (sb-ext:native-namestring (make-pathname :directory '(:relative) + :name "foo" + :type "txt")) + (sb-ext:native-namestring (let ((p (make-pathname :directory nil + :name "foo" + :type "txt"))) + (assert (not (pathname-directory p))) + p)))) + +;;; reported by Richard Kreuter: PATHNAME and MERGE-PATHNAMES used to +;;; be unsafely-flushable. Since they are known to return non-nil values +;;; only, the test-node of the IF is flushed, and since the function +;;; is unsafely-flushable, out it goes, and bad pathname designators +;;; breeze through. +;;; +;;; These tests rely on using a stream that appears as a file-stream +;;; but isn't a valid pathname-designator. +(assert (eq :false + (if (ignore-errors (pathname sb-sys::*tty*)) :true :false))) +(assert (eq :false + (if (ignore-errors (merge-pathnames sb-sys::*tty*)) :true :false))) + +;;; This used to return "quux/bar.lisp" +(assert (equal #p"quux/bar.fasl" + (let ((*default-pathname-defaults* #p"quux/")) + (compile-file-pathname "foo.lisp" :output-file "bar")))) +(assert (equal #p"quux/bar.fasl" + (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" "/"))) + ;;;; success -(quit :unix-status 104)