From 0567612118d44cde39bb41058a4d06e771fcf0c6 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 22 May 2009 06:16:20 +0000 Subject: [PATCH] 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. --- NEWS | 1 + src/code/filesys.lisp | 7 +++- src/code/win32-pathname.lisp | 2 +- tests/filesys.pure.lisp | 93 +++++++++++++++++++++++------------------- version.lisp-expr | 2 +- 5 files changed, 60 insertions(+), 45 deletions(-) diff --git a/NEWS b/NEWS index a3dacf7..1e63337 100644 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4