+;;; we got (truename "/") wrong for about 6 months. Check that it's
+;;; still right.
+(with-test (:name :root-truename :fails-on :win32)
+ (let ((pathname (truename "/")))
+ (assert (equalp pathname #p"/"))
+ (assert (equal (pathname-directory pathname) '(:absolute)))))
+\f
+;;; we failed to unparse logical pathnames with :NAME :WILD :TYPE NIL.
+;;; (Reported by Pascal Bourguignon.
+(with-test (:name :unparse-logical-wild)
+ (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:**;*\""))))
+\f
+;;; reported by James Y Knight on sbcl-devel 2006-05-17
+(with-test (:name :merge-back :fails-on :win32)
+ (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))
+(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)))))
+
+;;; 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.
+(with-test (:name :dont-flush-pathnames)
+ (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"
+(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"))))
+ (assert (equal #p"quux/bar.fasl"
+ (let ((*default-pathname-defaults* #p"quux/"))
+ (compile-file-pathname "bar.lisp")))))
+\f
+(with-test (:name :wild-enough)
+ (enough-namestring #p".a*"))
+\f
+
+(with-test (:name :translated-wild-version)
+ (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
+(with-test (:name :enough-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.
+(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
+ #|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).
+(with-test (:name :bug-489698 :skipped-on '(not :win32))
+ (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))))
+
+(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)))))
+