X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fpathnames.impure.lisp;h=4361c3dce0e0b91803251dc4882402bd1b110f88;hb=260de2062fca170efdac3e42491d7d866c2d2e56;hp=1c705a859b3e3b4e92da06fa14df38aacd10589d;hpb=4c81c652cdc32faefee1bccb84c3c9a7854e3edd;p=sbcl.git

diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 1c705a8..4361c3d 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -323,7 +323,7 @@
   (assert (raises-error? (merge-pathnames (make-string-output-stream))
                          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)
   (let ((pathnames (list
@@ -337,17 +337,17 @@
     (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~% ->~%~
+          (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~% ->~%~
                              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)))))
-       (print-not-readable ()
+                       (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)))))
 
 ;;; BUG 330: "PARSE-NAMESTRING should accept namestrings as the
@@ -400,7 +400,7 @@
 ;;; still right.
 (with-test (:name :root-truename)
   (let ((pathname (truename "/")))
-    (assert (equalp pathname #p"/"))
+    (assert (equalp pathname (merge-pathnames #p"/")))
     (assert (equal (pathname-directory pathname) '(:absolute)))))
 
 ;;; we failed to unparse logical pathnames with :NAME :WILD :TYPE NIL.
@@ -579,7 +579,9 @@
   ;; Not at the start of the first directory
   (assert (equal (native-namestring #p"foo/~/bar")
                  #-win32 "foo/~/bar"
-                 #+win32 "foo\\~\\bar")))
+                 #+win32 "foo\\~\\bar"))
+  (equal (native-namestring (merge-pathnames "~/"))
+         (native-namestring (user-homedir-pathname))))
 
 ;;; lp#673625
 (with-test (:name :pathname-escape-first-directory-component
@@ -592,4 +594,29 @@
   ;; * / :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-file-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