From 4699fc1db09eebbca9f9ce774a35656d1be37ace Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Mon, 22 Oct 2018 15:41:30 -0400 Subject: [PATCH] improved consistency of Windows filename handling original commit: 9017943cdba8c54c8f0acf20b037174780c10039 --- LOG | 5 +++ csug/io.stex | 4 +- mats/6.ms | 42 ++++++++++----------- release_notes/release_notes.stex | 14 +++++++ s/6.ss | 65 ++++++-------------------------- 5 files changed, 53 insertions(+), 77 deletions(-) diff --git a/LOG b/LOG index a8a2ecdf60..52c55e60c0 100644 --- a/LOG +++ b/LOG @@ -1016,3 +1016,8 @@ in threaded builds) when a lot of small objects are allocated by C code with no intervening Scheme-side allocation or dirty writes. alloc.c, types.h, externs.h +- made Windows filename handling in directory-list, file-access-time, + file-change-time, file-directory?, file-exists?, file-modification-time, + get-mode, and path-absolute more consistent with + https://docs.microsoft.com/en-us/windows/desktop/FileIO/naming-a-file + 6.ss, 6.ms, io.stex, release_notes.stex diff --git a/csug/io.stex b/csug/io.stex index f0d9c4400e..7eac9096a8 100644 --- a/csug/io.stex +++ b/csug/io.stex @@ -3687,9 +3687,9 @@ are involved. \begin{tabular}{llllllll} path & abs & first & rest & parent & last & root & ext \\ -\scheme{c:} & \scheme{#t} & \scheme{c:} & \scheme{_} & \scheme{c:} & \scheme{_} & \scheme{c:} & \scheme{_} \\ +\scheme{c:} & \scheme{#f} & \scheme{c:} & \scheme{_} & \scheme{c:} & \scheme{_} & \scheme{c:} & \scheme{_} \\ \scheme{c:/} & \scheme{#t} & \scheme{c:/} & \scheme{_} & \scheme{c:/} & \scheme{_} & \scheme{c:/} & \scheme{_} \\ -\scheme{c:a/b} & \scheme{#t} & \scheme{c:} & \scheme{a/b} & \scheme{c:a} & \scheme{b} & \scheme{c:a/b} & \scheme{_} \\ +\scheme{c:a/b} & \scheme{#f} & \scheme{c:} & \scheme{a/b} & \scheme{c:a} & \scheme{b} & \scheme{c:a/b} & \scheme{_} \\ \scheme{//s/a/b.c} & \scheme{#t} & \scheme{//s} & \scheme{a/b.c} & \scheme{//s/a} & \scheme{b.c} & \scheme{//s/a/b} & \scheme{c} \\ \scheme{//s.com} & \scheme{#t} & \scheme{//s.com} & \scheme{_} & \scheme{//s.com} & \scheme{_} & \scheme{//s.com} & \scheme{_} \\ \end{tabular} diff --git a/mats/6.ms b/mats/6.ms index f47e6239f3..667ecb6b4d 100644 --- a/mats/6.ms +++ b/mats/6.ms @@ -1673,7 +1673,7 @@ (begin (define-record $acyclic ((immutable notme))) (record-reader '$acyclic (type-descriptor $acyclic))) (xmat - "; Test error \"fasl object created by different release\"\n; This one is the list (a b c d) created by version 5.9b\n\n#@5.9babcd\f&\n" + "; Test error \"fasl object created by different release\"\n; This one is the list (a b c d) created by version 5.9b\n\n#@\x2;\x4;\x0;\x0;\x0;5.9b\x0;\x4;\x0;\x0;\x0;\x2;\x1;\x0;\x0;\x0;a\x2;\x1;\x0;\x0;\x0;b\x2;\x1;\x0;\x0;\x0;c\x2;\x1;\x0;\x0;\x0;d\f&\x0;\x0;\x0;\n" ) (xmat @@ -2858,7 +2858,7 @@ (or (not (windows?)) (> (length (directory-list "\\\\?\\c:\\")) 0)) (or (not (windows?)) - (> (length (directory-list "\\\\?\\c:")) 0)) + (> (length (directory-list "\\\\?\\C:\\")) 0)) (file-directory? "/") (file-directory? "/.") (file-exists? ".") @@ -2869,7 +2869,7 @@ (file-directory? "c:/.")) (not (file-directory? "c:"))) (if (windows?) - (and (file-directory? "\\\\?\\c:") + (and (not (file-directory? "\\\\?\\c:")) (file-directory? "\\\\?\\c:\\")) (not (file-directory? "\\\\?\\c:"))) (if (windows?) @@ -2878,7 +2878,7 @@ (file-exists? "c:/.")) (not (file-exists? "c:"))) (if (windows?) - (and (file-exists? "\\\\?\\c:") + (and (not (file-exists? "\\\\?\\c:")) (file-exists? "\\\\?\\c:\\")) (not (file-exists? "\\\\?\\c:"))) (if (windows?) @@ -2899,9 +2899,9 @@ (and (logtest m #o400) (not (logtest m #o111))))) (or (not (windows?)) - (and (fixnum? (get-mode "c:")) - (eqv? (get-mode "c:") (get-mode "c:/")) - (eqv? (get-mode "c:") (get-mode "c:/.")))) + (and (fixnum? (get-mode "c:/")) + (eqv? (get-mode "c:/") (get-mode "C:\\")) + (eqv? (get-mode "c:/") (get-mode "c:\\.")))) (if (or (windows?) (embedded?)) (fixnum? (get-mode "../mats")) (eqv? (logand (get-mode "../mats") #o700) #o700)) @@ -2930,9 +2930,9 @@ (time? (file-change-time "c:/")) (time? (file-modification-time "c:/")))) (or (not (windows?)) - (and (time? (file-access-time "\\\\?\\c:")) - (time? (file-change-time "\\\\?\\c:")) - (time? (file-modification-time "\\\\?\\c:")))) + (and (time? (file-access-time "\\\\?\\C:\\")) + (time? (file-change-time "\\\\?\\C:\\")) + (time? (file-modification-time "\\\\?\\C:\\")))) (or (not (windows?)) (and (time? (file-access-time "\\\\?\\c:\\")) (time? (file-change-time "\\\\?\\c:\\")) @@ -3120,9 +3120,7 @@ (eq? (path-absolute? "/abc") #t) (eq? (path-absolute? "foo") #f) (eq? (path-absolute? "foo/bar/a.b") #f) - (eq? - (path-absolute? "c:abc") - (and (windows?) #t)) + (eq? (path-absolute? "c:abc") #f) (equal? (path-parent "") "") (equal? (path-parent "a") "") @@ -3275,17 +3273,17 @@ ; windows (if (windows?) (table - ("c:" "t" "c:" "" "c:" "" "c:" "") + ("c:" "f" "c:" "" "c:" "" "c:" "") ("c:/" "t" "c:/" "" "c:/" "" "c:/" "") - ("c:.." "t" "c:" ".." "c:" ".." "c:.." "") - ("c:../" "t" "c:" "../" "c:.." "" "c:../" "") - ("c:../a" "t" "c:" "../a" "c:.." "a" "c:../a" "") - ("c:." "t" "c:" "." "c:" "." "c:." "") - ("c:./" "t" "c:" "./" "c:." "" "c:./" "") - ("c:./a" "t" "c:" "./a" "c:." "a" "c:./a" "") + ("c:.." "f" "c:" ".." "c:" ".." "c:.." "") + ("c:../" "f" "c:" "../" "c:.." "" "c:../" "") + ("c:../a" "f" "c:" "../a" "c:.." "a" "c:../a" "") + ("c:." "f" "c:" "." "c:" "." "c:." "") + ("c:./" "f" "c:" "./" "c:." "" "c:./" "") + ("c:./a" "f" "c:" "./a" "c:." "a" "c:./a" "") ("c:/abc" "t" "c:/" "abc" "c:/" "abc" "c:/abc" "") - ("c:abc" "t" "c:" "abc" "c:" "abc" "c:abc" "") - ("c:abc/def" "t" "c:" "abc/def" "c:abc" "def" "c:abc/def" "") + ("c:abc" "f" "c:" "abc" "c:" "abc" "c:abc" "") + ("c:abc/def" "f" "c:" "abc/def" "c:abc" "def" "c:abc/def" "") ("c:/abc/def" "t" "c:/" "abc/def" "c:/abc" "def" "c:/abc/def" "") ("//abc" "t" "//abc" "" "//abc" "" "//abc" "") ("//abc/" "t" "//abc" "" "//abc" "" "//abc/" "") diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 7f93595c35..289d6d1eb5 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -1592,6 +1592,20 @@ in fasl files does not generally make sense. %----------------------------------------------------------------------------- \section{Bug Fixes}\label{section:bugfixes} +\subsection{Disk-relative filenames in Windows (9.5.1)} + +In Windows, filenames that start with a disk designator but no +directory separator are now treated as relative paths. For example, +\scheme{(path-absolute? "C:")} now returns \scheme{#f}, and +\scheme{(directory-list "C:")} now lists the files in the current +directory on disk C instead of the files in the root directory of disk +C. + +In addition, \scheme{file-access-time}, \scheme{file-change-time}, +\scheme{file-directory?}, \scheme{file-exists?}, +\scheme{file-modification-time}, and \scheme{get-mode} no longer +remove trailing directory separators on Windows. + \subsection{Globally unique names on non-Windows systems no longer contain the IP address (9.5.1)} The globally unique names of gensyms no longer contain the IP address diff --git a/s/6.ss b/s/6.ss index 76da9a8227..14adf00cd5 100644 --- a/s/6.ss +++ b/s/6.ss @@ -128,15 +128,7 @@ (let ([x (fp path follow?)]) (if (fixnum? x) x - (if-feature windows - (let ([y (let ([n (string-length path)]) - (and (fx> n 0) - (fp (if (directory-separator? (string-ref path (fx- n 1))) - (substring path 0 (fx- n 1)) - (string-append path "\\")) - follow?)))]) - (if (fixnum? y) y (err x))) - (err x))))])))) + (err x)))])))) (let () (define file-x-time @@ -155,18 +147,7 @@ (let ([x (path-fp file follow?)]) (if (pair? x) (make-time 'time-utc (cdr x) (car x)) - (if-feature windows - (let ([y (let ([n (string-length file)]) - (and (fx> n 0) - (path-fp - (if (directory-separator? (string-ref file (fx- n 1))) - (substring file 0 (fx- n 1)) - (string-append file "\\")) - follow?)))]) - (if (pair? y) - (make-time 'time-utc (cdr y) (car y)) - (path-err file x))) - (path-err file x)))) + (path-err file x))) (let ([x (fd-fp (port-file-descriptor file))]) (cond [(pair? x) (make-time 'time-utc (cdr x) (car x))] @@ -208,9 +189,9 @@ (and (not (char=? (string-ref path i) #\*)) (nostars? (fx+ i 1)))))) ($oops who "invalid directory name ~s" path)) - (wl (if (directory-separator? (string-ref path (fx- n 1))) - (format "~a*" path) - (format "~a\\*" path)))))) + (wl (if (memv (string-ref path (fx- n 1)) '(#\\ #\/ #\:)) + (string-append path "*") + (string-append path "\\*")))))) (foreign-procedure "(cs)directory_list" (string) scheme-object))]) (lambda (path) (unless (string? path) ($oops who "~s is not a string" path)) @@ -237,15 +218,7 @@ [(path) (file-exists? path #t)] [(path follow?) (unless (string? path) ($oops who "~s is not a string" path)) - (if-feature windows - (or (fp path follow?) - (let ([n (string-length path)]) - (and (fx> n 0) - (fp (if (directory-separator? (string-ref path (fx- n 1))) - (substring path 0 (fx- n 1)) - (string-append path "\\")) - follow?)))) - (fp path follow?))])))) + (fp path follow?)])))) (define-who #(r6rs: file-exists?) (lambda (path) @@ -267,15 +240,7 @@ [(path) (file-directory? path #t)] [(path follow?) (unless (string? path) ($oops who "~s is not a string" path)) - (if-feature windows - (or (fp path follow?) - (let ([n (string-length path)]) - (and (fx> n 0) - (fp (if (directory-separator? (string-ref path (fx- n 1))) - (substring path 0 (fx- n 1)) - (string-append path "\\")) - follow?)))) - (fp path follow?))])))) + (fp path follow?)])))) (define-who file-symbolic-link? (let ([fp (foreign-procedure "(cs)file_symbolic_linkp" (string) boolean)]) @@ -376,7 +341,7 @@ (char=? (string-ref s 1) #\:) (let ([c (string-ref s 0)]) (or (char<=? #\a c #\z) (char<=? #\A c #\Z)))) - (if (and (>= n 3) (directory-separator? (string-ref s 2))) 3 2)] + (if (and (fx>= n 3) (directory-separator? (string-ref s 2))) 3 2)] [(and windows? (fx>= n 4) (char=? (string-ref s 0) #\\) @@ -388,7 +353,7 @@ (char=? (string-ref s 5) #\:) (let ([c (string-ref s 4)]) (or (char<=? #\a c #\z) (char<=? #\A c #\Z)))) - (if (and (>= n 7) (char=? (string-ref s 6) #\\)) 7 6)] + (if (and (fx>= n 7) (char=? (string-ref s 6) #\\)) 7 6)] [(and windows? (fx>= n 8) (char-ci=? (string-ref s 4) #\U) @@ -427,22 +392,16 @@ (set-who! path-absolute? (lambda (s) - (define directory-separator? (directory-separator-predicate s)) (unless (string? s) ($oops who "~s is not a string" s)) (let ([n (string-length s)]) (or (and (fx>= n 1) (directory-separator? (string-ref s 0))) (and (fx>= n 1) (char=? (string-ref s 0) #\~)) (and windows? - (fx>= n 2) + (fx>= n 3) (char=? (string-ref s 1) #\:) (let ([c (string-ref s 0)]) - (or (char<=? #\a c #\z) (char<=? #\A c #\Z)))) - (and windows? - (fx>= n 4) - (char=? (string-ref s 0) #\\) - (char=? (string-ref s 1) #\\) - (char=? (string-ref s 2) #\?) - (char=? (string-ref s 3) #\\)))))) + (or (char<=? #\a c #\z) (char<=? #\A c #\Z))) + (directory-separator? (string-ref s 2))))))) (set-who! path-extension (lambda (s)