X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ffilesys.pure.lisp;h=cff87b5f80d6abc51ea80602895f86c687530cea;hb=0e03a9ac950b78d776c4869c809e202d9e929f39;hp=4a5d0be218b480b2b657def74fe0526670100004;hpb=ffb8ca7616d75c88aae8f0939a241260ffdec051;p=sbcl.git

diff --git a/tests/filesys.pure.lisp b/tests/filesys.pure.lisp
index 4a5d0be..cff87b5 100644
--- a/tests/filesys.pure.lisp
+++ b/tests/filesys.pure.lisp
@@ -32,7 +32,8 @@
   ;; We know a little bit about the structure of this result;
   ;; let's test to make sure that this test file is in it.
   (assert (find-if (lambda (pathname)
-                     (search "tests/filesys.pure.lisp"
+                     (search #-win32 "tests/filesys.pure.lisp"
+                             #+win32 "tests\\filesys.pure.lisp"
                              (namestring pathname)))
                    dir)))
 ;;; In sbcl-0.9.7 DIRECTORY failed on pathnames with character-set
@@ -84,3 +85,59 @@
 ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.)
 (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")))
+  ;; FIXME: Other platforms don't do this: either fix Windows
+  ;; so that it works even with the same logic others use, or
+  ;; make this official. (Currently just a kludge.)
+  (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR\\"))))
+
+;;; 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.
+(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))))
+                               '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
+                                         (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 (assert (string= tricky-nnn native-namestring)))))