(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:
;;;
(assert (not (pathname-directory p)))
p))))
-;;; reported by Richard Kreuter: PATHNAME used to be unsafely-flushable
-(assert (eq :false (if (ignore-errors (pathname nil)) :true :false)))
+;;; 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"))))
+\f
+(enough-namestring #p".a*")
+\f
+
+(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" "/")))
\f
+;;; 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
projects / sbcl.git / blobdiff