X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ffilesys.pure.lisp;h=a08e1341dd26a84cbef5a954aed72e509e24b5a4;hb=2378406d6eda78090dfe05e372438495aeace5e0;hp=e9abce8496e15d1aa015fe9940604f5c4e48908e;hpb=fec3614baf361523a4fb154ed80d9b73e1452b2d;p=sbcl.git

diff --git a/tests/filesys.pure.lisp b/tests/filesys.pure.lisp
index e9abce8..a08e134 100644
--- a/tests/filesys.pure.lisp
+++ b/tests/filesys.pure.lisp
@@ -85,47 +85,109 @@
 (assert (typep (nth-value 1 (ignore-errors (file-length *terminal-io*)))
                'type-error))
 
+;;; A few cases Windows does have enough marbles to pass right now
+#+win32
+(progn
+  (assert (equal "C:\\FOO" (native-namestring "C:\\FOO")))
+  (assert (equal "C:\\FOO" (native-namestring "C:/FOO")))
+  (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR")))
+  (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR\\" :as-file t))))
+
+(with-test (:name (:parse-native-pathname :as-directory :junk-allowed))
+  (assert
+   (equal
+    (parse-native-namestring "foo.lisp" nil *default-pathname-defaults*
+                             :as-directory t)
+    (parse-native-namestring "foo.lisp" nil *default-pathname-defaults*
+                             :as-directory t
+                             :junk-allowed t))))
+
 ;;; Test for NATIVE-PATHNAME / NATIVE-NAMESTRING stuff
 ;;;
 ;;; given only safe characters in the namestring, NATIVE-PATHNAME will
 ;;; never error, and NATIVE-NAMESTRING on the result will return the
 ;;; original namestring.
-(let ((safe-chars
-       ;; for WIN32, we might want to remove #\: here
-       (coerce
-        (cons #\Newline
-              (loop for x from 32 to 127 collect (code-char x)))
-        'simple-base-string))
-      (tricky-sequences #("/../" "../" "/.." "." "/." "./" "/./"
-                          "[]" "*" "**" "/**" "**/" "/**/" "?"
-                          "\\*" "\\[]" "\\?" "\\*\\*" "*\\*")))
-  (loop repeat 1000
-        for length = (random 32)
-        for native-namestring = (coerce
-                                 (loop repeat length
-                                       collect
-                                       (char safe-chars
-                                             (random (length safe-chars))))
-                                 'simple-base-string)
-        for pathname = (native-pathname native-namestring)
-        for nnn = (native-namestring pathname)
-        do (assert (string= nnn native-namestring)))
-  (loop repeat 1000
-        for native-namestring = (with-output-to-string (s)
-                                  (loop
-                                   (let ((r (random 1.0)))
-                                     (cond
-                                       ((< r 1/20) (return))
-                                       ((< r 1/2)
-                                        (write-char
+(with-test (:name :random-native-namestrings)
+  (let ((safe-chars
+         (coerce
+          (cons #\Newline
+                (loop for x from 32 to 127 collect (code-char x)))
+          'simple-base-string))
+        (tricky-sequences #("/../" "../" "/.." "." "/." "./" "/./"
+                            "[]" "*" "**" "/**" "**/" "/**/" "?"
+                            "\\*" "\\[]" "\\?" "\\*\\*" "*\\*")))
+    (loop repeat 1000
+          for length = (random 32)
+          for native-namestring = (coerce
+                                   (loop repeat length
+                                         collect
                                          (char safe-chars
-                                               (random (length safe-chars)))
-                                         s))
-                                       (t (write-string
-                                           (aref tricky-sequences
-                                                 (random
-                                                  (length tricky-sequences)))
-                                           s))))))
-        for pathname = (native-pathname native-namestring)
-        for nnn = (native-namestring pathname)
-        do (assert (string= nnn native-namestring))))
+                                               (random (length safe-chars))))
+                                   'simple-base-string)
+          for pathname = (native-pathname native-namestring)
+          for nnn = (native-namestring pathname)
+          do #+win32
+             ;; We canonicalize to \ as the directory separator
+             ;; on windows -- though both \ and / are legal.
+             (setf native-namestring (substitute #\\ #\/ native-namestring))
+             (unless (string= nnn native-namestring)
+               (error "1: wanted ~S, got ~S" native-namestring nnn)))
+    (loop repeat 1000
+          for native-namestring = (with-output-to-string (s)
+                                    (write-string "mu" s)
+                                    (loop
+                                      (let ((r (random 1.0)))
+                                        (cond
+                                          ((< r 1/20) (return))
+                                          ((< r 1/2)
+                                           (write-char
+                                            (char safe-chars
+                                                  (random (length safe-chars)))
+                                            s))
+                                          (t (write-string
+                                              (aref tricky-sequences
+                                                    (random
+                                                     (length tricky-sequences)))
+                                              s))))))
+          for pathname = (native-pathname native-namestring)
+          for tricky-nnn = (native-namestring pathname)
+          do #+win32
+             ;; We canonicalize to \ as the directory separator
+             ;; on windows -- though both \ and / are legal.
+             (setf native-namestring (substitute #\\ #\/ native-namestring))
+             (unless (string= tricky-nnn native-namestring)
+               (error "2: wanted ~S, got ~S" native-namestring tricky-nnn)))))
+
+;;; USER-HOMEDIR-PATHNAME and the extension SBCL-HOMEDIR-PATHNAME both
+;;; used to call PARSE-NATIVE-NAMESTRING without supplying a HOST
+;;; argument, and so would lose when *DEFAULT-PATHNAME-DEFAULTS* was a
+;;; logical pathname.
+(with-test (:name :user-homedir-pathname-robustness)
+  (let ((*default-pathname-defaults* (pathname "SYS:")))
+    (assert (not (typep (user-homedir-pathname)
+                        'logical-pathname)))))
+
+(with-test (:name :sbcl-homedir-pathname-robustness)
+  (let ((*default-pathname-defaults* (pathname "SYS:")))
+    (assert (not (typep (sb-impl::sbcl-homedir-pathname)
+                        'logical-pathname)))))
+
+(with-test (:name :file-author-stringp)
+  #-win32
+  (assert (stringp (file-author (user-homedir-pathname))))
+  #+win32
+  (assert (not (file-author (user-homedir-pathname)))))
+(with-test (:name :file-write-date-integerp)
+  (assert (integerp (file-write-date (user-homedir-pathname)))))
+
+;;; Canonicalization of pathnames for DIRECTORY
+(with-test (:name :directory-/.)
+  (assert (equal (directory #p".") (directory #p"./")))
+  (assert (equal (directory #p".") (directory #p""))))
+(with-test (:name :directory-/..)
+  (assert (equal (directory #p"..") (directory #p"../"))))
+(with-test (:name :directory-unspecific)
+  (assert (equal (directory #p".")
+                 (directory (make-pathname
+                             :name :unspecific
+                             :type :unspecific)))))