suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improved consistency of Windows filename handling

Browse Source 
original commit: 9017943cdba8c54c8f0acf20b037174780c10039
This commit is contained in:
Bob Burger 2018-10-22 15:41:30 -04:00
parent 19f3c85fe2
commit 4699fc1db0
5 changed files with 53 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
LOG
View File

@ -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

4
csug/io.stex
View File

@ -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}

42
mats/6.ms
View File

@ -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/" "")

14
release_notes/release_notes.stex
View File

@ -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

63
s/6.ss
View File

@ -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))))
(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)