X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpathnames.impure.lisp;h=f675a8e14cbf4524f6a1e941e78533fb8fcb5f1f;hb=616e16f529572b23dbb4991b49bc7343cf0412bc;hp=1c705a859b3e3b4e92da06fa14df38aacd10589d;hpb=4c81c652cdc32faefee1bccb84c3c9a7854e3edd;p=sbcl.git

diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp
index 1c705a8..f675a8e 100644
--- a/tests/pathnames.impure.lisp
+++ b/tests/pathnames.impure.lisp
@@ -323,9 +323,9 @@
   (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)
+(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)
@@ -398,7 +398,7 @@
 
 ;;; 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)))))
@@ -412,7 +412,7 @@
     (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"))))
     (assert (equal (merge-pathnames p1 p2)
@@ -567,7 +567,7 @@
       (ignore-errors (delete-file bar))
       (setf (logical-pathname-translations "SYS") translations))))
 
-(with-test (:name :tilde-expansion)
+(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")
@@ -592,4 +592,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-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