X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpathnames.impure.lisp;h=f675a8e14cbf4524f6a1e941e78533fb8fcb5f1f;hb=885a956ae2044a0c5c4a2b55db8e32b7f6b48d05;hp=99d94c8c173c8aed3f0892cb13cbc7a38fe2564b;hpb=a647f35a48924c9bc1914e1286418309fc69704e;p=sbcl.git diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index 99d94c8..f675a8e 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -34,31 +34,31 @@ ;;; SBCL used to throw an error saying there's no translation. (with-test (:name (:logical-pathname 1)) (assert (equal (namestring (translate-logical-pathname "demo0:file.lisp")) - "/tmp/file.lisp"))) + "/tmp/file.lisp"))) ;;; We do not match a null directory to every wild path: (with-test (:name (:logical-pathname 2)) (assert (not (pathname-match-p "demo0:file.lisp" - (logical-pathname "demo0:tmp;**;*.*.*"))))) + (logical-pathname "demo0:tmp;**;*.*.*"))))) ;;; Remove "**" from our resulting pathname when the source-dir is NIL: (with-test (:name (:logical-pathname 3)) (setf (logical-pathname-translations "demo1") - '(("**;*.*.*" "/tmp/**/*.*") (";**;*.*.*" "/tmp/rel/**/*.*"))) + '(("**;*.*.*" "/tmp/**/*.*") (";**;*.*.*" "/tmp/rel/**/*.*"))) (assert (not (equal (namestring (translate-logical-pathname "demo1:foo.lisp")) "/tmp/**/foo.lisp")))) ;;; That should be correct: (with-test (:name (:logical-pathname 4)) (assert (equal (namestring (translate-logical-pathname "demo1:foo.lisp")) - "/tmp/foo.lisp"))) + "/tmp/foo.lisp"))) ;;; Check for absolute/relative path confusion: (with-test (:name (:logical-pathname 5)) (assert (not (equal (namestring (translate-logical-pathname "demo1:;foo.lisp")) - "tmp/rel/foo.lisp"))) + "tmp/rel/foo.lisp"))) (assert (equal (namestring (translate-logical-pathname "demo1:;foo.lisp")) - "/tmp/rel/foo.lisp"))) + "/tmp/rel/foo.lisp"))) ;;; Under SBCL: new function #'UNPARSE-ENOUGH-NAMESTRING, to ;;; handle the following case exactly (otherwise we get an error: @@ -76,12 +76,12 @@ ;;; insensitivity and a canonical case.) (with-test (:name (:logical-pathname 7)) (setf (logical-pathname-translations "FOO") - '(("**;*.*.*" "/full/path/to/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)))) + :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)))) @@ -96,16 +96,16 @@ (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 @@ -119,9 +119,9 @@ ;;; work ...) (with-test (:name (:logical-pathname 10)) (parse-namestring "" - (pathname-host - (translate-logical-pathname - "FOO:")))) + (pathname-host + (translate-logical-pathname + "FOO:")))) ;;; ANSI says PARSE-NAMESTRING returns TYPE-ERROR on host mismatch. (with-test (:name (:logical-pathname 11)) @@ -131,9 +131,9 @@ ;;; turning one logical pathname into another: (with-test (:name (:logical-pathname 12)) (setf (logical-pathname-translations "foo") - '(("todemo;*.*.*" "demo0:*.*.*"))) + '(("todemo;*.*.*" "demo0:*.*.*"))) (assert (equal (namestring (translate-logical-pathname "foo:todemo;x.y")) - (namestring (translate-logical-pathname "demo0:x.y"))))) + (namestring (translate-logical-pathname "demo0: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 @@ -157,8 +157,8 @@ (setf (logical-pathname-translations "test0") '(("**;*.*.*" "/library/foo/**/"))) (assert (equal (namestring (translate-logical-pathname - "test0:foo;bar;baz;mum.quux")) - "/library/foo/foo/bar/baz/mum.quux")) + "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/*/") @@ -167,22 +167,22 @@ (setf (logical-pathname-translations "prog") '(("CODE;*.*.*" "/lib/prog/"))) (assert (equal (namestring (translate-logical-pathname - "prog:code;documentation.lisp")) - "/lib/prog/documentation.lisp")) + "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"))) + "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. (with-test (:name (:logical-pathname 15)) (assert (equal (namestring (translate-logical-pathname - "test0:foo;bar;baz;mum.quux.3")) - "/library/foo/foo/bar/baz/mum.quux"))) + "test0:foo;bar;baz;mum.quux.3")) + "/library/foo/foo/bar/baz/mum.quux"))) ;;;; MERGE-PATHNAME tests @@ -211,100 +211,100 @@ (with-test (:name (:merge-pathname 1)) (loop for (expected-result . params) in - `( ;; trivial merge - (#P"/usr/local/doc/foo" #p"foo" #p"/usr/local/doc/") - ;; If pathname does not specify a host, device, directory, - ;; name, or type, each such component is copied from - ;; default-pathname. - ;; 1) no name, no type - (#p"/supplied-dir/name.type" #p"/supplied-dir/" #p"/dir/name.type") - ;; 2) no directory, no type - (#p"/dir/supplied-name.type" #p"supplied-name" #p"/dir/name.type") - ;; 3) no name, no dir (must use make-pathname as ".foo" is parsed - ;; as a name) - (#p"/dir/name.supplied-type" - ,(make-pathname :type "supplied-type") - #p"/dir/name.type") - ;; If (pathname-directory pathname) is a list whose car is - ;; :relative, and (pathname-directory default-pathname) is a - ;; list, then the merged directory is [...] - (#p"/aaa/bbb/ccc/ddd/qqq/www" #p"qqq/www" #p"/aaa/bbb/ccc/ddd/eee") - ;; except that if the resulting list contains a string or - ;; :wild immediately followed by :back, both of them are - ;; removed. - (#P"/aaa/bbb/ccc/blah/eee" - ;; "../" in a namestring is parsed as :up not :back, so make-pathname - ,(make-pathname :directory '(:relative :back "blah")) - #p"/aaa/bbb/ccc/ddd/eee") - ;; If (pathname-directory default-pathname) is not a list or - ;; (pathname-directory pathname) is not a list whose car is - ;; :relative, the merged directory is (or (pathname-directory - ;; pathname) (pathname-directory default-pathname)) - (#P"/absolute/path/name.type" - #p"/absolute/path/name" - #p"/dir/default-name.type") - ;; === logical pathnames === - ;; 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 - #+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 - ;; rather than default-pathname] - (#p"SCRATCH:FOO;NAME2" #p"scratch:;name2" #p"scratch:foo;") - ;; 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:DIR;SUPPLIED-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"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR" - ,(make-pathname :host "scratch" - :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") - #p"/aaa/bbb/ccc/ddd/eee") - (#p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE" - #p"scratch:absolute;path;name" #p"/dir/default-name.type") - - ;; 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))))) + `( ;; trivial merge + (#P"/usr/local/doc/foo" #p"foo" #p"/usr/local/doc/") + ;; If pathname does not specify a host, device, directory, + ;; name, or type, each such component is copied from + ;; default-pathname. + ;; 1) no name, no type + (#p"/supplied-dir/name.type" #p"/supplied-dir/" #p"/dir/name.type") + ;; 2) no directory, no type + (#p"/dir/supplied-name.type" #p"supplied-name" #p"/dir/name.type") + ;; 3) no name, no dir (must use make-pathname as ".foo" is parsed + ;; as a name) + (#p"/dir/name.supplied-type" + ,(make-pathname :type "supplied-type") + #p"/dir/name.type") + ;; If (pathname-directory pathname) is a list whose car is + ;; :relative, and (pathname-directory default-pathname) is a + ;; list, then the merged directory is [...] + (#p"/aaa/bbb/ccc/ddd/qqq/www" #p"qqq/www" #p"/aaa/bbb/ccc/ddd/eee") + ;; except that if the resulting list contains a string or + ;; :wild immediately followed by :back, both of them are + ;; removed. + (#P"/aaa/bbb/ccc/blah/eee" + ;; "../" in a namestring is parsed as :up not :back, so make-pathname + ,(make-pathname :directory '(:relative :back "blah")) + #p"/aaa/bbb/ccc/ddd/eee") + ;; If (pathname-directory default-pathname) is not a list or + ;; (pathname-directory pathname) is not a list whose car is + ;; :relative, the merged directory is (or (pathname-directory + ;; pathname) (pathname-directory default-pathname)) + (#P"/absolute/path/name.type" + #p"/absolute/path/name" + #p"/dir/default-name.type") + ;; === logical pathnames === + ;; 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 + #+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 + ;; rather than default-pathname] + (#p"SCRATCH:FOO;NAME2" #p"scratch:;name2" #p"scratch:foo;") + ;; 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:DIR;SUPPLIED-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"SCRATCH:AAA;BBB;CCC;DDD;FOO;BAR" + ,(make-pathname :host "scratch" + :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") + #p"/aaa/bbb/ccc/ddd/eee") + (#p"SCRATCH:ABSOLUTE;PATH;NAME.TYPE" + #p"scratch:absolute;path;name" #p"/dir/default-name.type") + + ;; 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))))) ;;; host-namestring testing (with-test (:name :host-namestring) (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 @@ -319,54 +319,54 @@ ;;; that those errors are gone: (with-test (:name (:string-streams-as-pathnames 1)) (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 +;;; ensure print-read consistency (or print-not-readable-error) on ;;; pathnames: -(with-test (:name :print/read-consistency) +(with-test (:name :print/read-consistency :fails-on :win32) (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) - (new (read-from-string (format nil "~S" p)))) - (unless (equal new p) - (let ((*print-readably* nil)) - (error "oops: host:~S device:~S dir:~S version:~S~% ->~%~ + (new (read-from-string (format nil "~S" p)))) + (unless (equal new p) + (let ((*print-readably* nil)) + (error "oops: host:~S device:~S dir:~S version:~S~% ->~%~ host:~S device:~S dir:~S version:~S" - (pathname-host p) (pathname-device p) - (pathname-directory p) (pathname-version p) - (pathname-host new) (pathname-device new) - (pathname-directory new) (pathname-version new))))) + (pathname-host p) (pathname-device p) + (pathname-directory p) (pathname-version p) + (pathname-host new) (pathname-device new) + (pathname-directory new) (pathname-version new))))) (print-not-readable () - nil))))) + nil))))) ;;; BUG 330: "PARSE-NAMESTRING should accept namestrings as the ;;; default argument" ...and streams as well (with-test (:name :parse-namestring/stream) (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))) + (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))) (when (probe-file test) - (delete-file test))))) + (delete-file test))))) ;;; ENOUGH-NAMESTRING should probably not fail when the namestring in ;;; question has a :RELATIVE pathname. @@ -383,22 +383,22 @@ ;;; :escape nil :readably nil. (with-test (:name :print-as-namestrings) (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))) + `((#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. -(with-test (:name :root-truename) +(with-test (:name :root-truename :fails-on :win32) (let ((pathname (truename "/"))) (assert (equalp pathname #p"/")) (assert (equal (pathname-directory pathname) '(:absolute))))) @@ -407,28 +407,28 @@ ;;; (Reported by Pascal Bourguignon. (with-test (:name :unparse-logical-wild) (let ((pathname (make-pathname :host "SYS" :directory '(:absolute :wild-inferiors) - :name :wild :type nil))) + :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 -(with-test (:name :merge-back) +(with-test (:name :merge-back :fails-on :win32) (let ((p1 (make-pathname :directory '(:relative "bar"))) - (p2 (make-pathname :directory '(:relative :back "foo")))) + (p2 (make-pathname :directory '(:relative :back "foo")))) (assert (equal (merge-pathnames p1 p2) - (make-pathname :directory '(:relative :back "foo" "bar")))))) + (make-pathname :directory '(:relative :back "foo" "bar")))))) ;;; construct native namestrings even if the directory is empty (means ;;; that same as if (:relative)) (with-test (:name :native-namestring) (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))))) + :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 @@ -440,18 +440,18 @@ ;;; but isn't a valid pathname-designator. (with-test (:name :dont-flush-pathnames) (assert (eq :false - (if (ignore-errors (pathname sb-sys::*tty*)) :true :false))) + (if (ignore-errors (pathname sb-sys::*tty*)) :true :false))) (assert (eq :false - (if (ignore-errors (merge-pathnames sb-sys::*tty*)) :true :false)))) + (if (ignore-errors (merge-pathnames sb-sys::*tty*)) :true :false)))) ;;; This used to return "quux/bar.lisp" (with-test (:name :dpd-output-file) (assert (equal #p"quux/bar.fasl" - (let ((*default-pathname-defaults* #p"quux/")) - (compile-file-pathname "foo.lisp" :output-file "bar")))) + (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"))))) + (let ((*default-pathname-defaults* #p"quux/")) + (compile-file-pathname "bar.lisp"))))) (with-test (:name :wild-enough) (enough-namestring #p".a*")) @@ -466,11 +466,11 @@ (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)))))) + (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 (with-test (:name :enough-relative-to-root) @@ -482,16 +482,16 @@ ;;; denotation of SBCL's then-current pathname implementation. (with-test (:name (:native-namestring 2)) (assert (equal - (loop with components = (list nil :unspecific "" "a") - for name in components - appending (loop for type in components - as pathname = (make-pathname - #+win32 :device #+win32 "C" - :directory '(:absolute "tmp") - :name name :type type) - collect (ignore-errors - (sb-ext:native-namestring pathname)))) - #-win32 + (loop with components = (list nil :unspecific "" "a") + for name in components + appending (loop for type in components + as pathname = (make-pathname + #+win32 :device #+win32 "C" + :directory '(:absolute "tmp") + :name name :type type) + collect (ignore-errors + (sb-ext:native-namestring pathname)))) + #-win32 #|type NIL :UNSPECIFIC "" "a" |# #|name |# #|NIL |# '("/tmp/" "/tmp/" NIL NIL @@ -531,8 +531,7 @@ ;;; 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) +(with-test (:name :bug-489698 :skipped-on '(not :win32)) (assert (equal (make-pathname :directory '(:absolute)) (read-from-string "#p\"\\\\\\\\\"")))) @@ -568,4 +567,54 @@ (ignore-errors (delete-file bar)) (setf (logical-pathname-translations "SYS") translations)))) +(with-test (:name :tilde-expansion :fails-on :win32) + (assert (equal '(:absolute :home "foo") (pathname-directory "~/foo/bar.txt"))) + (assert (equal '(:absolute (:home "jdoe") "quux") (pathname-directory "~jdoe/quux/"))) + (assert (equal "~/foo/x" (namestring (make-pathname :directory '(:absolute :home "foo") + :name "x")))) + (assert (equal (native-namestring (merge-pathnames "a/b.c" (user-homedir-pathname))) + (native-namestring #p"~/a/b.c"))) + ;; Not a directory. + (assert (equal (native-namestring #p"~foo") "~foo")) + ;; Not at the start of the first directory + (assert (equal (native-namestring #p"foo/~/bar") + #-win32 "foo/~/bar" + #+win32 "foo\\~\\bar"))) + +;;; lp#673625 +(with-test (:name :pathname-escape-first-directory-component + :fails-on :win32) + ;; ~ / :HOME + (assert (equal (pathname-directory #p"\\~/foo/") '(:relative "~" "foo"))) + (assert (equal (native-namestring #p"\\~/foo/") "~/foo/")) + (assert (equal (namestring (make-pathname :directory '(:absolute "~zot"))) + "\\~zot/")) + ;; * / :WILD + (assert (equal (pathname-directory #p"\\*/") '(:relative "*")))) + +(with-test (:name :ensure-directories-exist-with-odd-d-p-d) + (let ((*default-pathname-defaults* #p"/tmp/foo")) + (ensure-directories-exist "/"))) + +(with-test (:name :long-file-name :skipped-on '(not :win32)) + (let* ((x '("hint--if-you-are-having-trouble-deleting-this-test-directory" + "use-the-7zip-file-manager")) + (base (truename + (directory-namestring (or *load-pathname* *compile-pathname*)))) + (shallow (make-pathname :directory `(:relative ,(car x)))) + (shallow (merge-pathnames shallow base)) + (deep (make-pathname + :directory `(:relative ,@(loop repeat 10 appending x)))) + (deep (merge-pathnames deep base)) + (native (sb-ext:native-namestring deep))) + (assert (> (length native) 260)) + (assert (eql 3 (mismatch "\\\\?" native))) + (assert (not (probe-file shallow))) + (unwind-protect + (progn + (ensure-directories-exist deep) + (assert (probe-file deep))) + (sb-ext:delete-directory shallow :recursive t)) + (assert (not (probe-file shallow))))) + ;;;; success