X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpathnames.impure.lisp;h=e2c200e8a09c20781caa70ab533efffed65d78fc;hb=57eae6573811f44abe167a9015116d95371543bb;hp=280334b5d14fbb9787116a9a6ecc804f07065b78;hpb=175c318c892b0627b36fa3c4db66f59680242204;p=sbcl.git diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index 280334b..e2c200e 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -20,12 +20,11 @@ (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). +;;; In case of a parse error we want to get a condition of type TYPE-ERROR, +;;; because ANSI says so. (This used to be PARSE-ERROR.) (assert (typep (grab-condition (logical-pathname "demo0::bla;file.lisp")) - 'parse-error)) + 'type-error)) ;;; some things SBCL-0.6.9 used not to parse correctly: ;;; @@ -356,5 +355,167 @@ (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" "/"))) + +;;; Check the handling of NIL, :UNSPECIFIC, the empty string, and +;;; non-NIL strings in NATIVE-NAMESTRING implementations. Revised by +;;; RMK 2007-11-28, attempting to preserve the apparent intended +;;; denotation of SBCL's then-current pathname implementation. +(assert (equal + (loop with components = (list nil :unspecific "" "a") + for name in components + appending (loop for type in components + as pathname = (make-pathname + #+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 +#|:UNSPECIFIC|# "/tmp/" "/tmp/" NIL NIL +#|"" |# "/tmp/" "/tmp/" "/tmp/." "/tmp/.a" +#|"a" |# "/tmp/a" "/tmp/a" "/tmp/a." "/tmp/a.a") + + #+win32 + #|type NIL :UNSPECIFIC "" "a" |# +#|name |# +#|NIL |# '("C:\\tmp\\" "C:\\tmp\\" NIL NIL +#|:UNSPECIFIC|# "C:\\tmp\\" "C:\\tmp\\" NIL NIL +#|"" |# "C:\\tmp\\" "C:\\tmp\\" "C:\\tmp\\." "C:\\tmp\\.a" +#|"a" |# "C:\\tmp\\a" "C:\\tmp\\a" "C:\\tmp\\a." "C:\\tmp\\a.a"))) + +(with-test (:name :delete-file-logical-pathname) + (setf (logical-pathname-translations "SB-TEST") + (list (list "**;*.*.*" (make-pathname :name :wild + :type :wild + :defaults (truename "."))))) + (let ((test (pathname "SB-TEST:delete-logical-pathname.tmp"))) + (assert (typep test 'logical-pathname)) + (with-open-file (f test :direction :output) + (write-line "delete me!" f)) + (assert (probe-file test)) + (assert (delete-file test)) + (assert (not (probe-file test))))) + +(with-test (:name :logical-pathname-type-error) + (assert (eq :type-error-ok + (handler-case (logical-pathname "FOO.txt") + (type-error () :type-error-ok)))) + (assert (eq :type-error-ok + (handler-case (logical-pathname "SYS:%") + (type-error () :type-error-ok))))) + +;;; 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) + (assert (equal (make-pathname :directory '(:absolute)) + (read-from-string "#p\"\\\\\\\\\"")))) + +(with-test (:name :load-logical-pathname-translations) + (let* ((cwd (truename ".")) + (foo (merge-pathnames "llpnt-foo.translations" cwd)) + (bar (merge-pathnames "llpnt-bar.translations" cwd)) + (translations (logical-pathname-translations "SYS"))) + (unwind-protect + (progn + (with-open-file (f foo :direction :output) + (prin1 (list (list "*.TEXT" (make-pathname + :directory '(:absolute "my" "foo") + :name :wild :type "txt"))) + f)) + (with-open-file (f bar :direction :output) + (prin1 (list (list "*.CL" (make-pathname + :directory '(:absolute "my" "bar") + :name :wild :type "lisp"))) f)) + (setf (logical-pathname-translations "SYS") + (list* (list "SITE;LLPNT-FOO.TRANSLATIONS.NEWEST" foo) + (list "SITE;LLPNT-BAR.TRANSLATIONS.NEWEST" bar) + translations)) + (assert (load-logical-pathname-translations "LLPNT-FOO")) + (assert (load-logical-pathname-translations "LLPNT-BAR")) + (assert + (and + (equal "/my/bar/quux.lisp" + (namestring (translate-logical-pathname "LLPNT-BAR:QUUX.CL"))) + (equal "/my/foo/quux.txt" + (namestring (translate-logical-pathname "LLPNT-FOO:QUUX.TEXT")))))) + (ignore-errors (delete-file foo)) + (ignore-errors (delete-file bar)) + (setf (logical-pathname-translations "SYS") translations)))) ;;;; success