1.0.28.69: filesystem tests and small Windows improvements

* FILE-AUTHOR returns NIL instead of signalling an error on Windows

* Missing DIRECTORY canonicalization tests.

* Check one-letter devices for being alpha-chars when unparsing
  them on Windows.

* NATIVE-NAMESTRING now has similar tailing-slash handling
  on Windows as elsewhere -- adjust the test.

* Windows namestrings canonicalize / to \ -- make the random
  namestring tests take that into account.

  ...filesys.pure.lisp passes on Windows.

diff --git a/NEWS b/NEWS
index a3dacf7..1e63337 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -50,6 +50,7 @@
   * improvement: pretty-printing loop has been implemented properly. (thanks
     to Tobias Rittweiler)
   * documentation: CLOS slot typechecing policy has been documented.
+  * bug fix: FILE-AUTHOR no longer signals an error on Windows.
   * bug fix: SB-SPROF could be foiled by foreign code not have a frame
     pointer, leading to memory faults. (thanks to Bart Botta)
   * bug fix: better floating point exception handling on x86/OpenBSD.

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index 526c2c7..ecb6cd2 100644 (file)
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -294,7 +294,8 @@
         (multiple-value-bind (existsp errno ino mode nlink uid gid rdev size
                                       atime mtime)
             (sb!unix:unix-stat filename)
-          (declare (ignore ino nlink gid rdev size atime))
+          (declare (ignore ino nlink gid rdev size atime
+                           #!+win32 uid))
           (if existsp
               (case query-for
                 (:existence (nth-value
@@ -322,7 +323,9 @@
                              ;; ... but without any trailing slash.
                              :as-directory (eql (logand  mode sb!unix:s-ifmt)
                                                 sb!unix:s-ifdir))))
-                (:author (sb!unix:uid-username uid))
+                (:author
+                 #!-win32
+                 (sb!unix:uid-username uid))
                 (:write-date (+ unix-to-universal-time mtime)))
               (progn
                 ;; SBCL has for many years had a policy that a pathname

diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp
index 80ea088..8edaeda 100644 (file)
--- a/src/code/win32-pathname.lisp
+++ b/src/code/win32-pathname.lisp
@@ -165,7 +165,7 @@
         (directory (pathname-directory pathname)))
     (cond ((or (null device) (eq device :unspecific))
            "")
-          ((= 1 (length device))
+          ((and (= 1 (length device)) (alpha-char-p (char device 0)))
            (concatenate 'simple-string device ":"))
           ((and (consp directory) (eq :relative (car directory)))
            (error "No printed representation for a relative UNC pathname."))

diff --git a/tests/filesys.pure.lisp b/tests/filesys.pure.lisp
index 9a4afe8..4be0257 100644 (file)
--- a/tests/filesys.pure.lisp
+++ b/tests/filesys.pure.lisp
@@ -92,10 +92,7 @@
   (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\\"))))
+  (assert (equal "C:\\FOO\\BAR" (native-namestring "C:\\FOO\\BAR\\" :as-file t))))
 
 ;;; Test for NATIVE-PATHNAME / NATIVE-NAMESTRING stuff
 ;;;
@@ -104,43 +101,54 @@
 ;;; 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
+         (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 tricky-nnn = (native-namestring pathname)
-      do (assert (string= tricky-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
@@ -157,7 +165,10 @@
                         'logical-pathname)))))
 
 (with-test (:name :file-author-stringp)
-  (assert (stringp (file-author (user-homedir-pathname)))))
+  #-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)))))
 

diff --git a/version.lisp-expr b/version.lisp-expr
index 7d7fe8c..ecaf8b4 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.28.68"
+"1.0.28.69"