X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpathnames.impure.lisp;h=4361c3dce0e0b91803251dc4882402bd1b110f88;hb=260de2062fca170efdac3e42491d7d866c2d2e56;hp=04720a7badc3ec0ea29a48b001a922df073ebb83;hpb=dea1e4258272053e8ccda1bf670d43b429878fe2;p=sbcl.git diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index 04720a7..4361c3d 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -32,7 +32,7 @@ ;;; some things SBCL-0.6.9 used not to parse correctly: ;;; ;;; SBCL used to throw an error saying there's no translation. -(with-test (:name (:logical-pathname 1) :fails-on :win32) +(with-test (:name (:logical-pathname 1)) (assert (equal (namestring (translate-logical-pathname "demo0:file.lisp")) "/tmp/file.lisp"))) @@ -49,12 +49,12 @@ "/tmp/**/foo.lisp")))) ;;; That should be correct: -(with-test (:name (:logical-pathname 4) :fails-on :win32) +(with-test (:name (:logical-pathname 4)) (assert (equal (namestring (translate-logical-pathname "demo1:foo.lisp")) "/tmp/foo.lisp"))) ;;; Check for absolute/relative path confusion: -(with-test (:name (:logical-pathname 5) :fails-on :win32) +(with-test (:name (:logical-pathname 5)) (assert (not (equal (namestring (translate-logical-pathname "demo1:;foo.lisp")) "tmp/rel/foo.lisp"))) (assert (equal (namestring (translate-logical-pathname "demo1:;foo.lisp")) @@ -153,7 +153,7 @@ ;;; there's some code in this section which should be attributed ;;; to something in the ANSI spec, but I don't know what code it is ;;; or what section of the specification has the related code. -(with-test (:name (:logical-pathname 14) :fails-on :win32) +(with-test (:name (:logical-pathname 14)) (setf (logical-pathname-translations "test0") '(("**;*.*.*" "/library/foo/**/"))) (assert (equal (namestring (translate-logical-pathname @@ -179,7 +179,7 @@ ;;; ANSI section 19.3.1.1.5 specifies that translation to a filesystem ;;; which doesn't have versions should ignore the version slot. CMU CL ;;; didn't ignore this as it should, but we do. -(with-test (:name (:logical-pathname 15) :fails-on :win32) +(with-test (:name (:logical-pathname 15)) (assert (equal (namestring (translate-logical-pathname "test0:foo;bar;baz;mum.quux.3")) "/library/foo/foo/bar/baz/mum.quux"))) @@ -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 :fails-on :win32) +(with-test (:name :print/read-consistency) (let ((pathnames (list (make-pathname :name "foo" :type "txt" :version :newest) (make-pathname :name "foo" :type "txt" :version 1) @@ -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 @@ -398,9 +398,9 @@ ;;; we got (truename "/") wrong for about 6 months. Check that it's ;;; still right. -(with-test (:name :root-truename :fails-on :win32) +(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. @@ -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 :fails-on :win32) +(with-test (:name :merge-back) (let ((p1 (make-pathname :directory '(:relative "bar"))) (p2 (make-pathname :directory '(:relative :back "foo")))) (assert (equal (merge-pathnames p1 p2) @@ -535,7 +535,7 @@ (assert (equal (make-pathname :directory '(:absolute)) (read-from-string "#p\"\\\\\\\\\"")))) -(with-test (:name :load-logical-pathname-translations :fails-on :win32) +(with-test (:name :load-logical-pathname-translations) (let* ((cwd (truename ".")) (foo (merge-pathnames "llpnt-foo.translations" cwd)) (bar (merge-pathnames "llpnt-bar.translations" cwd)) @@ -567,7 +567,7 @@ (ignore-errors (delete-file bar)) (setf (logical-pathname-translations "SYS") translations)))) -(with-test (:name :tilde-expansion :fails-on :win32) +(with-test (:name :tilde-expansion) (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") @@ -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,8 +594,7 @@ ;; * / :WILD (assert (equal (pathname-directory #p"\\*/") '(:relative "*")))) -(with-test (:name :ensure-directories-exist-with-odd-d-p-d - :fails-on :win32) +(with-test (:name :ensure-directories-exist-with-odd-d-p-d) (let ((*default-pathname-defaults* #p"/tmp/foo")) (ensure-directories-exist "/"))) @@ -601,7 +602,7 @@ (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*)))) + (directory-namestring (or *load-pathname* *compile-file-pathname*)))) (shallow (make-pathname :directory `(:relative ,(car x)))) (shallow (merge-pathnames shallow base)) (deep (make-pathname