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

io: repairs for Windows path maniplation

Browse Source 
Perpetuate a failure to make Windows paths behave reasonably with
path-manipulation functions.

In one case, the new implementation seemed better than the old one, so
I've changed the old implementation (by deleting code) and test cases.
The old code would split "x /y" to "\\?\REL\x " and "y", and the new
one splits to "x /" and "y"; the trailing separator is now enough to
preserve the space character, and it also preserves the directoryness
of the path. Of course, "x /" splits to 'relative and "\\?\REL\x " as
it strips away the trailing "/".

A remaining problem in both implementations: some Windows API
functions implicitly erase a trailing "." in a directory name, making
"x./y" equivalent to "x/y". The Racket path-manipulation functions
don't do that, so splitting and recombining "x./y" does not access the
same path as the original. This apparently hasn't been a problem in
practice, and there are so many terrible hacks already, so I left it
alone.

The new implementation perpetuates also the implementation mistake of
representing paths internally as byte strings. If, in some terrible
universe, I'm forced to do this again, the right choice is probably to
keep the path in a parsed form with enough information to reconstruct
the original, but with the information sorted nicely to make various
normalizations and combinations easy.
This commit is contained in:
Matthew Flatt 2018-03-21 12:34:30 -06:00
parent e031e04f62
commit 0ebcb23244
15 changed files with 630 additions and 354 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
INSTALL.txt
View File

@ -177,12 +177,13 @@ Instructions: Building Racket Pieces" further below.
More Instructions: Building Racket-on-Chez
==========================================
The `make cs` target (or `make cs-as-is` for a rebuild) builds an
experimental variant of Racket that runs on Chez Scheme. The
executables for the Racket-on-Chez variant all have a "cs" or "CS"
suffix, so they coexist with a traditional Racket build. (One day, if
the experiment goes well, there will be an option or default to build
Racket-on-Chez as `racket` instead of `racketcs`.)
The `make cs` target (or `make cs-as-is` for a rebuild, or `nmake
win32-cs` on Windows with Visual Studio) builds an experimental
variant of Racket that runs on Chez Scheme. The executables for the
Racket-on-Chez variant all have a "cs" or "CS" suffix, so they coexist
with a traditional Racket build. (One day, if the experiment goes
well, there will be an option or default to build Racket-on-Chez as
`racket` instead of `racketcs`.)
Building Racket-on-Chez requires an existing Racket and Chez Scheme.
If you use `make cs` with no further arguments, then the build process
@ -192,12 +193,15 @@ downloading and building Chez Scheme.
If you have a sufficiently recent Racket installation already with at
least the "compiler-lib" and "parser-tools-libs" packages installed,
you can supply `RACKET=...` with `make cs` to skip that part of the
bootstrap. And if you have a Chez Scheme source directory already, you
can supply that with `SCHEME_SRC=...` instead of downloading a new
bootstrap. And if you have a Chez Scheme source directory already[*],
you can supply that with `SCHEME_SRC=...` instead of downloading a new
copy.
make cs RACKET=racket SCHEME_SRC=path/to/ChezScheme
[*] For now, RacketCS requires the variant of Chez Scheme at
https://github.com/mflatt/ChezScheme
Even More Instructions: Building Racket Pieces
==============================================

23
Makefile
View File

@ -86,7 +86,10 @@ in-place-setup:
win32-in-place:
$(MAKE) win32-base
$(MAKE) win32-pkgs-catalog SRC_CATALOG="$(SRC_CATALOG)"
$(MAKE) win32-in-place-after-base PKGS="$(PKGS)" SRC_CATALOG="$(SRC_CATALOG)" WIN32_PLAIN_RACKET="$(WIN32_PLAIN_RACKET)"
win32-in-place-after-base:
$(MAKE) win32-pkgs-catalog SRC_CATALOG="$(SRC_CATALOG)" WIN32_PLAIN_RACKET="$(WIN32_PLAIN_RACKET)"
$(WIN32_RUN_RACO) pkg update $(UPDATE_PKGS_ARGS)
$(WIN32_RUN_RACO) pkg install $(INSTALL_PKGS_ARGS)
$(WIN32_RUN_RACO) setup --only-foreign-libs $(ALL_PLT_SETUP_OPTIONS)
@ -284,6 +287,24 @@ racket/src/build/ChezScheme:
update-ChezScheme:
cd racket/src/build/ChezScheme && git pull && git submodule update
WIN32_CS_COPY_ARGS_EXCEPT_PKGS = SRC_CATALOG="$(SRC_CATALOG)"
WIN32_CS_COPY_ARGS = PKGS="$(PKGS)" $(WIN32_CS_COPY_ARGS_EXCEPT_PKGS)
win32-cs:
IF "$(RACKET)" == "" $(MAKE) win32-racket-then-cs $(WIN32_CS_COPY_ARGS)
IF not "$(RACKET)" == "" $(MAKE) win32-just-cs RACKET="$(RACKET)" SCHEME_SRC="$(SCHEME_SRC)" $(WIN32_CS_COPY_ARGS)
win32-racket-then-cs:
$(MAKE) win32-in-place PKGS="" $(WIN32_CS_COPY_ARGS_EXCEPT_PKGS)
$(MAKE) win32-just-cs RACKET=$(WIN32_PLAIN_RACKET) SCHEME_SRC="$(SCHEME_SRC)" $(WIN32_CS_COPY_ARGS)
win32-just-cs:
cmd /c $(RACKET) racket\src\worksp\csbuild.rkt --scheme-dir "$(SCHEME_SRC)"
IF NOT EXIST build\config cmd /c mkdir build\config
cmd /c echo #hash((links-search-files . ())) > build\config\config.rktd
racket\racketcs -G build\config -N raco -l- raco setup $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)
$(MAKE) win32-in-place-after-base WIN32_PLAIN_RACKET=racket\racketcs $(WIN32_CS_COPY_ARGS)
# ------------------------------------------------------------
# Configuration options for building installers

23
pkgs/racket-test-core/tests/racket/path.rktl
View File

@ -728,11 +728,11 @@
(test (list #f (string->path "\\\\?\\c:\\a\\\\\\")) get-base (coerce "\\\\?\\c:\\a\\\\\\"))
(test (list (string->path "\\\\?\\UNC\\") (string->path "\\\\?\\REL\\\\x/y")) get-base (coerce "\\\\?\\UNC\\x/y"))
(test (list #f (string->path "\\\\?\\UNC\\x\\y")) get-base (coerce "\\\\?\\UNC\\x\\y"))
(test (list (string->path "\\\\?\\REL\\\\x\\y ") (string->path "z")) get-base (coerce "x/y /z"))
(test (list (string->path "\\\\?\\REL\\\\y ") (string->path "z")) get-base (coerce "x/../y /z"))
(test (list (string->path "\\\\?\\REL\\..\\\\y ") (string->path "z")) get-base (coerce "../y /z"))
(test (list (string->path "\\\\?\\c:\\y ") (string->path "z")) get-base (coerce "c:/y /z"))
(test (list (string->path "\\\\?\\c:\\y ") (string->path "z")) get-base (coerce "c:/../y /z"))
(test (list (string->path "x/y /") (string->path "z")) get-base (coerce "x/y /z"))
(test (list (string->path "x/../y /") (string->path "z")) get-base (coerce "x/../y /z"))
(test (list (string->path "../y /") (string->path "z")) get-base (coerce "../y /z"))
(test (list (string->path "c:/y /") (string->path "z")) get-base (coerce "c:/y /z"))
(test (list (string->path "c:/../y /") (string->path "z")) get-base (coerce "c:/../y /z"))
(test (list (string->path "../aux/") (string->path "z")) get-base (coerce "../aux/z"))
(test (list (string->path "../aux.m/") (string->path "z")) get-base (coerce "../aux.m/z"))
(test (list (string->path "../") (string->path "\\\\?\\REL\\\\aux.m")) get-base (coerce "../aux.m/"))
@ -790,6 +790,10 @@
(test (bytes->path #"\\\\?\\UNC\\a\\b/c\\") simplify-path (coerce "\\\\?\\UnC\\a\\b/c") #f)
(test (bytes->path #"\\\\a\\b\\") simplify-path (coerce "\\\\?\\UnC\\a\\b") #f)
(test (bytes->path #"\\\\?\\c:\\a/b") simplify-path (coerce "\\\\?\\c:\\a/b") #f)
(test (bytes->path #"\\\\?\\UNC\\a\\b \\") simplify-path (coerce "\\\\?\\UNC\\a\\b ") #f)
(test (bytes->path #"\\\\?\\UNC\\a\\b \\") simplify-path (coerce "\\\\?\\\\UNC\\a\\b ") #f)
(test (bytes->path #"\\\\?\\UNC\\a\\b.\\") simplify-path (coerce "\\\\?\\UNC\\a\\b.") #f)
(test (bytes->path #"\\\\?\\UNC\\a\\b.\\") simplify-path (coerce "\\\\?\\\\UNC\\a\\b.") #f)
(test (bytes->path #"..\\") simplify-path (coerce "\\\\?\\REL\\..") #f)
(test (bytes->path #"..\\") simplify-path (coerce "\\\\?\\REL\\..\\") #f)
@ -932,8 +936,17 @@
(test "Apple" path-element->string (string->path-element "Apple"))
(test "Apple" path-element->string (bytes->path-element #"Apple"))
(test #"a" path-element->bytes (bytes->path #"\\\\?\\REL\\a" 'windows))
(test #"a" path-element->bytes (bytes->path #"\\\\?\\REL\\\\a" 'windows))
(test #".." path-element->bytes (bytes->path #"\\\\?\\REL\\\\.." 'windows))
(test (bytes->path #"\\\\?\\REL\\\\.." 'windows) bytes->path-element #".." 'windows)
(test (bytes->path #"\\\\?\\REL\\\\:" 'windows) bytes->path-element #":" 'windows)
(test (bytes->path #"abc" 'windows) bytes->path-element #"abc" 'windows)
(err/rt-test (path-element->bytes (string->path ".")))
(err/rt-test (path-element->bytes (string->path "..")))
(err/rt-test (path-element->bytes (bytes->path #"\\\\?\\REL\\.." 'windows)))
(err/rt-test (path-element->bytes (bytes->path #"\\\\?\\RED\\a" 'windows)))
(err/rt-test (bytes->path-element #"." 'unix))
(err/rt-test (bytes->path-element #".." 'unix))
(err/rt-test (bytes->path-element "a/b" 'unix))

1
racket/collects/setup/cross-system.rkt
View File

@ -13,6 +13,7 @@
(unless cross-system-table
(define lib-dir (find-lib-dir))
(define ht (and lib-dir
(eq? (system-type 'vm) 'racket) ; only the Racket VM supports cross-compilation, for now
(let ([f (build-path lib-dir "system.rktd")])
(and (file-exists? f)
(let ([ht (call-with-default-reading-parameterization

8
racket/src/io/README.txt
View File

@ -1,7 +1,7 @@
This package implements the port, path, encoding, printing, and
formatting layer. It can be run in a host Racket with `make demo`, but
it's meant to be compiled for use in Racket on Chez Scheme; see
"../cs/README.txt".
This directory implements the port, path, encoding, printing, and
formatting layer. It can be run in a host Racket with `make demo`,
which is useful for development and debugging, but it's meant to be
compiled for use in Racket on Chez Scheme; see "../cs/README.txt".
Core error support must be provided as a more primitive layer,
including the exception structures and error functions that do not

135
racket/src/io/path/build.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../locale/string.rkt"
"../format/main.rkt"
"check.rkt"
"path.rkt"
"sep.rkt"
@ -26,8 +27,9 @@
(check-build-path-arg who sub)
(loop (argument->convention sub convention who #:first? #f)
(cdr subs))])))
(path (append-path-parts convention who base subs)
convention))
(define final-convention (or convention (system-path-convention-type)))
(path (append-path-parts final-convention who base subs)
final-convention))
;; ----------------------------------------
@ -58,7 +60,7 @@
(cond
[(path? p) (check (path-convention p))]
[(string? p) (check (system-path-convention-type))]
[else (or convention (system-path-convention-type))]))
[else convention]))
;; ----------------------------------------
@ -75,16 +77,20 @@
(convert-to-initial-backslash-backslash-questionmark bstr)
(list (strip-trailing-spaces bstr)))]
[else (list bstr)])))
(define unc-result?
(and (eq? convention 'windows)
(not result-is-backslash-backslash-questionmark?)
(parse-unc (car base-accum) 0)))
;; The `accum` list accumulates byte strings in reverse order to be
;; appended. On Windows in \\?\ mode, each byte string corresponds
;; to a single path element with a leading backslash, except that
;; the last item is a arting-point`; otherwise, the byte strings can
;; the last item is a starting-point; otherwise, the byte strings can
;; be a mixture of compound path elements and separators
(let loop ([accum base-accum] [subs subs] [first? #t])
(cond
[(null? subs)
(define elems (reverse accum))
(combine-build-elements elems)]
(combine-build-elements elems unc-result?)]
[else
(define sub (car subs))
(define bstr (as-bytes sub))
@ -116,7 +122,7 @@
(raise-arguments-error who
(string-append what " cannot be added to a base path")
what sub
"base path" (path (combine-build-elements (reverse accum))
"base path" (path (combine-build-elements (reverse accum) unc-result?)
'windows)))
(loop (combine-windows-path (if (and (null? subs)
;; because \\?\ mode does its own stripping:
@ -124,7 +130,8 @@
bstr
(strip-trailing-spaces bstr))
accum
result-is-backslash-backslash-questionmark?)
result-is-backslash-backslash-questionmark?
(null? (cdr subs)))
(cdr subs)
#f))
(cond
@ -133,9 +140,10 @@
[(backslash-backslash-questionmark? bstr)
(define-values (kind drive-len orig-drive-len clean-start-pos add-sep-pos)
(parse-backslash-backslash-questionmark bstr))
(define abs? (or (eq? kind 'abs) (eq? kind 'unc)))
(combine (eq? kind 'rel)
(eq? kind 'abs)
(and (eq? kind 'abs)
abs?
(and abs?
(just-backslashes-after? bstr drive-len)))]
[(parse-unc bstr 0)
=> (lambda (drive-len)
@ -147,27 +155,31 @@
[else
(combine #t #f #f)])])])))
(define (combine-windows-path bstr accum result-is-backslash-backslash-questionmark?)
(define (combine-windows-path bstr accum result-is-backslash-backslash-questionmark? is-last?)
(cond
[result-is-backslash-backslash-questionmark?
;; Split `bstr` into pieces, and handle the pieces one-by-one
(let loop ([elems (windows-split-into-path-elements bstr)] [accum accum])
(let loop ([elems (windows-split-into-path-elements bstr is-last?)] [accum accum] [to-dir? #f])
(cond
[(null? elems) accum]
[(null? elems)
(if (and is-last? to-dir? (pair? (cdr accum)))
(cons (bytes-append (car accum) #"\\") (cdr accum))
accum)]
[else
(define sub (car elems))
(cond
[(eq? 'same sub)
;; Ignore 'same for \\?\ mode
(loop (cdr elems) accum)]
(loop (cdr elems) accum #t)]
[(eq? 'up sub)
;; Drop previous element for 'up in \\?\ mode
(loop (cdr elems)
(if (null? (cdr accum))
(list (starting-point-add-up (car accum)))
(cdr accum)))]
(cdr accum))
#t)]
[else
(loop (cdr elems) (cons sub accum))])]))]
(loop (cdr elems) (cons sub accum) #f)])]))]
[else
;; Not in \\?\ mode, so `bstr` must not be a \\?\ path.
;; In case `accum` is drive-relative, start by dropping any
@ -189,16 +201,18 @@
new-accum
(cons sub new-accum))]))
(define (windows-split-into-path-elements bstr)
(define (windows-split-into-path-elements bstr keep-trailing-separator?)
(cond
[(backslash-backslash-questionmark? bstr)
;; It must be REL or RED (with only a drive to build on)
(define-values (dots-end literal-start)
(backslash-backslash-questionmark-dot-ups-end bstr (bytes-length bstr)))
(append (extract-dot-ups bstr 8 (or dots-end 8))
(extract-separate-parts bstr literal-start #:bbq-mode? #t))]
(extract-separate-parts bstr literal-start
#:bbq-mode? #t
#:keep-trailing-separator? keep-trailing-separator?))]
[else
(extract-separate-parts bstr 0)]))
(extract-separate-parts bstr 0 #:keep-trailing-separator? keep-trailing-separator?)]))
(define (as-bytes p)
(cond
@ -227,23 +241,25 @@
[(letter-drive-start? s (bytes-length s))
(just-separators-after? s 2)]))
(struct starting-point (bstr ; byte string that contains the starting path
(struct starting-point (kind ; 'rel, 'red, 'unc, or 'abs
bstr ; byte string that contains the starting path
len ; number of bytes to use when adding more element
orig-len ; number of bytes to use when not adding more elements
extra-sep ; extra separator before first added element
add-ups? ; whether to add `up`s to the base string, as opposed to dropping them
drive?)) ; is bstr an absolute root?
(define (make-starting-point bstr
(define (make-starting-point kind
bstr
len
#:orig-len [orig-len len]
#:extra-sep [extra-sep #""]
#:add-ups? [add-ups? #f]
#:drive? [drive? #t])
(list
(starting-point bstr len orig-len extra-sep add-ups? drive?)))
(starting-point kind bstr len orig-len extra-sep add-ups? drive?)))
(define (combine-build-elements elems)
(define (combine-build-elements elems unc-result?)
(cond
[(starting-point? (car elems))
;; in \\?\ mode for Windows
@ -258,23 +274,38 @@
#"."]
[(equal? bstr #"\\\\?\\RED")
#"\\"]
[else bstr]))]
[else
(case (starting-point-kind s)
[(rel unc)
;; Canonical form of \\?\REL\..[\..[etc.]] or \\?\UNC\[etc.] ends in slash:
(if (eqv? (bytes-ref bstr (sub1 (bytes-length bstr))) (char->integer #\\))
bstr
(bytes-append bstr #"\\"))]
[else bstr])]))]
[else
(define init-bstr (subbytes (starting-point-bstr s)
0
(starting-point-len s)))
(define rel-..-special-case? (and (bytes=? init-bstr #"\\\\?\\REL")
(bytes=? (cadr elems) #"\\..")))
(apply bytes-append
init-bstr
(if rel-..-special-case? ; => need extra `\` to indicate that ".." is not 'up
#"\\"
#"")
(case (starting-point-kind s)
[(rel red) #"\\"]
[else #""])
(starting-point-extra-sep s)
(cdr elems))])]
[else
;; simple case
(apply bytes-append elems)]))
;; simple case...
(define bstr (apply bytes-append elems))
;; ... unless we've accidentally constructed something that
;; looks like a \\?\ path or a UNC path, in which case we can
;; correct by dropping a leading [back]slash
(cond
[(backslash-backslash-questionmark? bstr)
(subbytes bstr 1)]
[(and (not unc-result?)
(parse-unc bstr 0))
(subbytes bstr 1)]
[else bstr])]))
(define (convert-to-initial-backslash-backslash-questionmark bstr)
(cond
@ -282,19 +313,19 @@
(define-values (kind drive-len orig-drive-len clean-start-pos add-sep)
(parse-backslash-backslash-questionmark bstr))
(case kind
[(abs)
[(abs unc)
(append (reverse (extract-separate-parts bstr drive-len #:bbq-mode? #t))
(if (equal? add-sep #"")
;; drop implicit terminator in drive:
(make-starting-point bstr (sub1 drive-len) #:orig-len orig-drive-len)
(make-starting-point bstr drive-len #:orig-len orig-drive-len #:extra-sep (subbytes add-sep 1))))]
(make-starting-point kind bstr (sub1 drive-len) #:orig-len orig-drive-len)
(make-starting-point kind bstr drive-len #:orig-len orig-drive-len #:extra-sep (subbytes add-sep 1))))]
[else
;; We can't back up over any dots before `dots-end`,
;; so keep those toegether with \\?\REL
(define-values (dots-end literal-start)
(backslash-backslash-questionmark-dot-ups-end bstr (bytes-length bstr)))
(append (reverse (extract-separate-parts bstr literal-start #:bbq-mode? #t))
(make-starting-point bstr (or dots-end 7) #:add-ups? (eq? kind 'rel) #:drive? #f))])]
(make-starting-point kind bstr (or dots-end 7) #:add-ups? (eq? kind 'rel) #:drive? #f))])]
[(parse-unc bstr 0)
=> (lambda (root-len)
(define-values (machine volume)
@ -303,23 +334,23 @@
(append (reverse (simplify-dots (extract-separate-parts bstr root-len) #:drop-leading? #t))
(let* ([unc-bstr (bytes-append #"\\\\?\\UNC" machine volume)]
[unc-len (bytes-length unc-bstr)])
(make-starting-point unc-bstr unc-len))))]
(make-starting-point 'unc unc-bstr unc-len))))]
[(bytes=? #"." bstr)
(make-starting-point #"\\\\?\\REL" 7 #:add-ups? #t #:drive? #f)]
(make-starting-point 'rel #"\\\\?\\REL" 7 #:add-ups? #t #:drive? #f)]
[(bytes=? #".." bstr)
(make-starting-point #"\\\\?\\REL\\.." 10 #:add-ups? #t #:drive? #f)]
(make-starting-point 'rel #"\\\\?\\REL\\.." 10 #:add-ups? #t #:drive? #f)]
[(is-sep? (bytes-ref bstr 0) 'windows)
(append (reverse (extract-separate-parts bstr 0))
(make-starting-point #"\\\\?\\RED" 7 #:drive? #f))]
(make-starting-point 'red #"\\\\?\\RED" 7 #:drive? #f))]
[(and ((bytes-length bstr) . >= . 2)
(drive-letter? (bytes-ref bstr 0))
(eqv? (bytes-ref bstr 1) (char->integer #\:)))
(append (reverse (simplify-dots (extract-separate-parts bstr 2) #:drop-leading? #t))
(let ([drive-bstr (bytes-append #"\\\\?\\" (subbytes bstr 0 2) #"\\")])
(make-starting-point drive-bstr 6 #:orig-len 7)))]
(make-starting-point 'abs drive-bstr 6 #:orig-len 7)))]
[else
;; Create \\?\REL, combinding any leading dots into the \\?\REL part:
(define elems (simplify-dots (extract-separate-parts bstr 2) #:drop-leading? #f))
(define elems (simplify-dots (extract-separate-parts bstr 0) #:drop-leading? #f))
(let loop ([dots null] [elems elems])
(cond
[(or (null? elems)
@ -327,13 +358,15 @@
(append (reverse elems)
(let* ([rel-bstr (apply bytes-append #"\\\\?\\REL" dots)]
[rel-len (bytes-length rel-bstr)])
(make-starting-point rel-bstr rel-len #:add-ups? #t #:drive? #f)))]
(make-starting-point 'rel rel-bstr rel-len #:add-ups? #t #:drive? #f)))]
[else
(loop (cons (car elems) dots) (cdr elems))]))]))
;; Split on separators, removing trailing whitespace from the last
;; element, and prefix each extracted element with a backslash:
(define (extract-separate-parts bstr pos #:bbq-mode? [bbq-mode? #f])
(define (extract-separate-parts bstr pos
#:bbq-mode? [bbq-mode? #f]
#:keep-trailing-separator? [keep-trailing-separator? #f])
(define (is-a-sep? b)
(if bbq-mode?
(eqv? b (char->integer #\\))
@ -363,7 +396,11 @@
(bytes=? new-bstr #".."))
'up]
[else
(bytes-append #"\\" new-bstr)]))
(if (and keep-trailing-separator?
(null? rest)
(end-pos . < . len))
(bytes-append #"\\" new-bstr #"\\")
(bytes-append #"\\" new-bstr))]))
(cons new-sub rest)]
[else (e-loop (add1 end-pos))]))])))
@ -399,10 +436,10 @@
(let loop ([bstrs bstrs] [accum null])
(cond
[(null? bstrs) (reverse accum)]
[(eq? 'up (car bstrs)) (loop (cdr bstrs) accum)]
[(eq? 'same (car bstrs)) (if (null? accum)
(if drop-leading?
(loop (cdr bstrs) accum)
(loop (cdr bstrs) (cons (car bstrs) accum)))
(loop (cdr bstrs) (cdr accum)))]
[(eq? 'same (car bstrs)) (loop (cdr bstrs) accum)]
[(eq? 'up (car bstrs)) (if (null? accum)
(if drop-leading?
(loop (cdr bstrs) accum)
(loop (cdr bstrs) (cons (car bstrs) accum)))
(loop (cdr bstrs) (cdr accum)))]
[else (loop (cdr bstrs) (cons (car bstrs) accum))])))

64
racket/src/io/path/cleanse.rkt
View File

@ -41,29 +41,35 @@
(eqv? (bytes-ref bstr (- literal-start 2)) (char->integer #\\))))
(cond
[has-extra-backslash? (return new-bstr)]
[(= literal-start (bytes-length new-bstr)) (return new-bstr)]
[else
(return (bytes-append (subbytes new-bstr 0 literal-start)
#"\\"
(subbytes new-bstr literal-start)))])])]
[(parse-unc bstr 0)
=> (lambda (drive-len)
(return (clean-double-slashes bstr 'windows drive-len)))]
(return (clean-double-slashes bstr 'windows (sub1 drive-len)
#:to-backslash-from 0)))]
[(letter-drive-start? bstr (bytes-length bstr))
(cond
[(and ((bytes-length bstr) . > . 2)
(is-sep? (bytes-ref bstr 2) 'windows))
(return (clean-double-slashes bstr 'windows 2))]
(return (clean-double-slashes bstr 'windows 2
#:to-backslash-from 2))]
[else
(return (bytes-append (subbytes bstr 0 2)
#"\\"
(clean-double-slashes (subbytes bstr 2) 'windows 0)))])]
(clean-double-slashes (subbytes bstr 2) 'windows 0
#:to-backslash-from 0)))])]
[else
(return (clean-double-slashes bstr 'windows 0))])]))
(return (clean-double-slashes bstr 'windows 0
#:to-backslash-from 0))])]))
;; ----------------------------------------
(define (clean-double-slashes bstr convention allow-double-before
#:only-backslash? [only-backslash? #f])
#:only-backslash? [only-backslash? #f]
#:to-backslash-from [to-backslash-from #f])
(define (is-a-sep? b)
(if only-backslash?
(eqv? b (char->integer #\\))
@ -77,18 +83,36 @@
(add1 (loop (sub1 i)))]
[else (loop (sub1 i))])))
(cond
[(zero? extra-count)
bstr]
[else
(define new-bstr (make-bytes (- (bytes-length bstr) extra-count)))
(let loop ([i (sub1 (bytes-length bstr))] [j (sub1 (bytes-length new-bstr))])
(unless (i . <= . allow-double-before)
(cond
[(and (is-a-sep? (bytes-ref bstr i))
(is-a-sep? (bytes-ref bstr (sub1 i))))
(loop (sub1 i) j)]
[else
(bytes-set! new-bstr j (bytes-ref bstr i))
(loop (sub1 i) (sub1 j))])))
(bytes-copy! new-bstr 0 bstr 0 (add1 allow-double-before))
new-bstr]))
[(and (zero? extra-count)
(or (not to-backslash-from)
(not (for/or ([b (in-bytes bstr to-backslash-from)])
(eq? b (char->integer #\/))))))
bstr]
[else
(define new-bstr (make-bytes (- (bytes-length bstr) extra-count)))
(let loop ([i (sub1 (bytes-length bstr))] [j (sub1 (bytes-length new-bstr))])
(unless (i . <= . allow-double-before)
(cond
[(is-a-sep? (bytes-ref bstr i))
(cond
[(is-a-sep? (bytes-ref bstr (sub1 i)))
(loop (sub1 i) j)]
[else
(if to-backslash-from
(bytes-set! new-bstr j (char->integer #\\))
(bytes-set! new-bstr j (bytes-ref bstr i)))
(loop (sub1 i) (sub1 j))])]
[else
(bytes-set! new-bstr j (bytes-ref bstr i))
(loop (sub1 i) (sub1 j))])))
(cond
[to-backslash-from
(bytes-copy! new-bstr 0 bstr 0 to-backslash-from)
(for ([i (in-range to-backslash-from (add1 allow-double-before))])
(define b (bytes-ref bstr i))
(if (eqv? b (char->integer #\/))
(bytes-set! new-bstr i (char->integer #\\))
(bytes-set! new-bstr i b)))]
[else
(bytes-copy! new-bstr 0 bstr 0 (add1 allow-double-before))])
new-bstr]))

4
racket/src/io/path/directory-path.rkt
View File

@ -48,7 +48,9 @@
(or (eqv? (bytes-ref bstr (sub1 len)) (char->integer #\\))
(and (not require-sep?)
(eq? 'rel (backslash-backslash-questionmark-kind bstr))
(eqv? len (backslash-backslash-questionmark-dot-ups-end bstr len))))]
(eqv? len
(let-values ([(dots-end literal-start) (backslash-backslash-questionmark-dot-ups-end bstr len)])
dots-end))))]
[else (unixish-path-directory-path?)])]))
(define (path->path-without-trailing-separator p)

39
racket/src/io/path/main.rkt
View File

@ -14,7 +14,8 @@
"directory-path.rkt"
"system.rkt"
"api.rkt"
"ffi.rkt")
"ffi.rkt"
"windows.rkt")
(provide (rename-out [is-path? path?])
path-for-some-system?
@ -87,23 +88,32 @@
(check-path-bytes who bstr)
(do-bytes->path-element bstr convention who bstr))
(define (path-element? p)
(define (path-element-clean p)
(cond
[(path? p)
(define bstr (path-bytes p))
(define convention (path-convention p))
(and
;; Quick pre-check: any separators?
;; Quick pre-check: any separators that are not at the end?
(or (not (eq? convention 'unix))
(not (for/or ([c (in-bytes bstr)]
(not (for/or ([c (in-bytes bstr 0 (let loop ([end (bytes-length bstr)])
(cond
[(zero? end) 0]
[(is-sep? (bytes-ref bstr (sub1 end)) convention)
(loop (sub1 end))]
[else end])))]
[i (in-naturals)])
(and (is-sep? c convention)
i))))
(let-values ([(base name dir?) (split-path p)])
(and (symbol? base)
(path? name))))]
(path? name)
name)))]
[else #f]))
(define (path-element? p)
(and (path-element-clean p) #t))
(define (do-bytes->path-element bstr convention who orig-arg)
(define (bad-element)
(raise-arguments-error who
@ -124,12 +134,23 @@
p)
(define/who (path-element->string p)
(check who path-element? p)
(bytes->string/locale (path-bytes p) #\?))
(define clean-p (path-element-clean p))
(unless clean-p
(check who path-element? p))
(bytes->string/locale (strip-//?/rel clean-p) #\?))
(define/who (path-element->bytes p)
(check who path-element? p)
(bytes-copy (path-bytes p)))
(define clean-p (path-element-clean p))
(unless clean-p
(check who path-element? p))
(bytes-copy (strip-//?/rel clean-p)))
(define (strip-//?/rel elem-p)
(define bstr (path-bytes elem-p))
(cond
[(eq? (path-convention elem-p) 'windows)
(strip-backslash-backslash-rel bstr)]
[else bstr]))
(define/who path<?
(case-lambda

7
racket/src/io/path/path.rkt
View File

@ -16,7 +16,12 @@
#:property prop:custom-write
(lambda (p port mode)
(when mode
(write-string "#<path:" port))
(if (eq? (path-convention p) (system-path-convention-type))
(write-string "#<path:" port)
(begin
(write-string "#<" port)
(write-string (symbol->string (path-convention p)) port)
(write-string "-path:" port))))
(write-string (bytes->string/locale (path-bytes p)) port)
(when mode
(write-string ">" port)))

313
racket/src/io/path/simplify.rkt
View File

@ -10,7 +10,8 @@
"cleanse.rkt"
"directory-path.rkt"
"complete.rkt"
"parameter.rkt")
"parameter.rkt"
"windows.rkt")
(provide simplify-path)
@ -18,78 +19,92 @@
(check-path-argument who p-in)
(define p (->path p-in))
(define convention (path-convention p))
(when use-filesystem?
(unless (eq? convention (system-path-convention-type))
(raise-arguments-error who
"in use-filesystem mode, path is not for the current platform"
"path" p)))
(cond
[(simple? p convention) p]
[else
(define clean-p (cleanse-path p))
(cond
[(simple? clean-p convention) clean-p]
[else
(define l (explode-path clean-p))
(define simple-p
(cond
[use-filesystem?
;; Use the filesystem, which requires building
;; a full path
(define (combine base accum)
(if (null? accum)
base
(apply build-path base (reverse accum))))
(let loop ([l (if (path? (car l)) (cdr l) l)]
[base (if (path? (car l))
;; convert starting point absolute as needed
(path->complete-path (car l) (current-directory))
;; original must be relative
(current-directory))]
[accum '()]
[seen #hash()])
(cond
[(null? l) (combine base accum)]
[(eq? 'same (car l))
(loop (cdr l) base accum seen)]
[(eq? 'up (car l))
(define new-base (combine base accum))
(define target (resolve-path new-base))
(define-values (from-base new-seen)
(cond
[(eq? target new-base) (values new-base seen)]
[else
(define from-base
(cond
[(complete-path? target) target]
[else
(define-values (base-dir name dir?) (split-path new-base))
(path->complete-path target base-dir)]))
(when (hash-ref seen from-base #f)
(raise
(exn:fail:filesystem
(string-append (symbol->string who) ": cycle detected at link"
"\n link path: " (path->string new-base))
(current-continuation-marks))))
(values from-base (hash-set seen from-base #t))]))
(define-values (next-base name dir?) (split-path from-base))
[(simple? clean-p convention) clean-p]
[else
(define l (explode-path clean-p))
(define simple-p
(cond
[use-filesystem?
;; Use the filesystem, which requires building
;; a full path
(define (combine base accum)
(if (null? accum)
base
(apply build-path base (reverse accum))))
(let loop ([l (if (path? (car l)) (cdr l) l)]
[base (if (path? (car l))
;; convert starting point absolute as needed
(path->complete-path (car l) (current-directory))
;; original must be relative
(current-directory))]
[accum '()]
[seen #hash()])
(cond
[(null? l) (combine base accum)]
[(eq? 'same (car l))
(loop (cdr l) base accum seen)]
[(eq? 'up (car l))
(define new-base (combine base accum))
(define target (resolve-path new-base))
(define-values (from-base new-seen)
(cond
[(eq? target new-base) (values new-base seen)]
[else
(define from-base
(cond
[(complete-path? target) target]
[else
(define-values (base-dir name dir?) (split-path new-base))
(path->complete-path target base-dir)]))
(when (hash-ref seen from-base #f)
(raise
(exn:fail:filesystem
(string-append (symbol->string who) ": cycle detected at link"
"\n link path: " (path->string new-base))
(current-continuation-marks))))
(values from-base (hash-set seen from-base #t))]))
(define-values (next-base name dir?) (split-path from-base))
(cond
[(not next-base)
;; discard ".." after a root
(loop (cdr l) from-base '() new-seen)]
[else
(loop (cdr l) next-base '() new-seen)])]
[else (loop (cdr l) base (cons (car l) accum) seen)]))]
[else
;; Don't use the filesystem, so just remove
;; "." and ".." syntactically
(define simpler-l
(let loop ([l l] [accum null])
(cond
[(not next-base)
;; discard ".." after a root
(loop (cdr l) from-base '() new-seen)]
[else
(loop (cdr l) next-base '() new-seen)])]
[else (loop (cdr l) base (cons (car l) accum) seen)]))]
[else
;; Don't use the filesystem, so just remove
;; "." and ".." syntactically
(define simpler-l
(let loop ([l l] [accum null])
(cond
[(null? l) (reverse accum)]
[(eq? 'same (car l)) (loop (cdr l) accum)]
[(and (eq? 'up (car l)) (pair? accum))
(loop (cdr l) (cdr accum))]
[else (loop (cdr l) (cons (car l) accum))])))
(apply build-path simpler-l)]))
(if (directory-path? p)
(path->directory-path simple-p)
simple-p)])]))
[(null? l) (reverse accum)]
[(eq? 'same (car l)) (loop (cdr l) accum)]
[(eq? 'up (car l))
(cond
[(pair? accum)
(loop (cdr l) (cdr accum))]
[else
(cons 'up (loop (cdr l) null))])]
[else (loop (cdr l) (cons (car l) accum))])))
(apply build-path/convention-type convention (if (null? simpler-l) '(same) simpler-l))]))
(define simpler-p (if (eq? convention 'windows)
(simplify-backslash-backslash-questionmark simple-p)
simple-p))
(if (or (directory-path? p)
(and (eq? convention 'windows)
(unc-without-trailing-separator? simpler-p)))
(path->directory-path simpler-p)
simpler-p)])]))
;; ----------------------------------------
@ -97,28 +112,144 @@
(define (simple? p convention)
(define bstr (path-bytes p))
(define len (bytes-length bstr))
(let loop ([i 0])
(cond
[(= i len) #t]
[(is-sep? (bytes-ref bstr i) convention)
(define (is-a-sep? b)
(if (eq? convention 'windows)
(eqv? b (char->integer #\\))
(is-sep? b convention)))
(cond
[(and (eq? convention 'windows)
(cond
[(and
(= len 2)
(letter-drive-start? bstr 2))
;; Letter drive without trailing separator
#t]
[(non-normal-backslash-backslash-questionmark? bstr)
#t]
[else #f]))
#f]
[else
(let loop ([i 0])
(cond
[(= i len) #t]
[(is-a-sep? (bytes-ref bstr i))
(cond
[(= (add1 i) len) #t]
[(is-a-sep? (bytes-ref bstr (add1 i)))
#f]
[(and (eqv? (bytes-ref bstr (add1 i)) (char->integer #\.))
(or (= (+ i 2) len)
(is-a-sep? (bytes-ref bstr (+ i 2)))
(and (eqv? (bytes-ref bstr (+ i 2)) (char->integer #\.))
(or (= (+ i 3) len)
(is-a-sep? (bytes-ref bstr (+ i 3)))))))
#f]
[else (loop (add1 i))])]
[(and (zero? i)
(eqv? (bytes-ref bstr 0) (char->integer #\.))
(or (= 1 len)
(is-sep? (bytes-ref bstr 1) convention)
(and (eqv? (bytes-ref bstr 1) (char->integer #\.))
(or (= 2 len)
(is-sep? (bytes-ref bstr 2) convention)))))
#f]
[(and (eq? convention 'windows)
(eqv? (bytes-ref bstr i) (char->integer #\/)))
#f]
[else (loop (add1 i))]))]))
(define (non-normal-backslash-backslash-questionmark? bstr)
(define-values (kind drive-len orig-drive-len clean-start-pos sep-bstr)
(parse-backslash-backslash-questionmark bstr))
;; We could try harder to recognize normal forms, but for now
;; we assume that some normalization is needed in a \\?\ path.
kind)
;; ----------------------------------------
(define (unc-without-trailing-separator? p)
(define bstr (path-bytes p))
(eqv? (parse-unc bstr 0) (bytes-length bstr)))
;; Strip away "\\?\" when possible from an otherwise simplified `p`
(define (simplify-backslash-backslash-questionmark p)
(define bstr (path-bytes p))
(define len (bytes-length bstr))
(define-values (kind drive-len orig-drive-len clean-start-pos sep-bstr)
(parse-backslash-backslash-questionmark bstr))
(define (special-element? elem-start i at-end?)
(and (elem-start . < . i)
(or (let ([b (bytes-ref bstr (sub1 i))])
(or (and (eqv? b (char->integer #\.))
(or at-end?
(= elem-start (- i 1))
(and (= elem-start (- i 2))
(eqv? (bytes-ref bstr elem-start) (char->integer #\.)))))
(and at-end?
(eqv? b (char->integer #\space)))))
(special-filename? (subbytes bstr elem-start i)))))
(define (no-special-in-content? start-pos #:len [len len])
(let loop ([i start-pos] [elem-start start-pos])
(cond
[(= (add1 i) len) #t]
[(is-sep? (bytes-ref bstr (add1 i)) convention)
#f]
[(and (eq? (bytes-ref bstr (add1 i)) (char->integer #\.))
(or (= (+ i 2) len)
(is-sep? (bytes-ref bstr (+ i 2)) convention)
(and (eq? (bytes-ref bstr (+ i 2)) (char->integer #\.))
(or (= (+ i 3) len)
(is-sep? (bytes-ref bstr (+ i 3)) convention)))))
#f]
[else (loop (add1 i))])]
[(and (zero? i)
(eq? (bytes-ref bstr 0) (char->integer #\.))
(or (= 1 len)
(is-sep? (bytes-ref bstr 1) convention)
(and (eq? (bytes-ref bstr 1) (char->integer #\.))
(or (= 2 len)
(is-sep? (bytes-ref bstr 2) convention)))))
#f]
[else (loop (add1 i))])))
[(= i len) (not (special-element? elem-start i #t))]
[else
(define b (bytes-ref bstr i))
(cond
[(eqv? b (char->integer #\\))
(cond
[(special-element? elem-start i #f) #f]
[else (loop (add1 i) (add1 i))])]
[(or (eqv? b (char->integer #\/))
(eqv? b (char->integer #\:))
(eqv? b (char->integer #\"))
(eqv? b (char->integer #\|))
(eqv? b (char->integer #\<))
(eqv? b (char->integer #\>)))
#f]
[else (loop (add1 i) elem-start)])])))
(case kind
[(abs)
(cond
[(and (= drive-len 7)
(drive-letter? (bytes-ref bstr 4))
(eqv? (bytes-ref bstr 5) (char->integer #\:))
(no-special-in-content? orig-drive-len))
(path (subbytes bstr 4) 'windows)]
[else p])]
[(unc)
(define norm-bstr (normalize-backslash-backslash-unc bstr))
(cond
[(no-special-in-content? 4 ; check UNC machine and drive, too
#:len (if (= orig-drive-len len)
(sub1 len) ; stop before ending "\\"
len))
(path (bytes-append #"\\" (subbytes norm-bstr 7)) 'windows)]
[(eq? norm-bstr bstr) p]
[else (path norm-bstr 'windows)])]
[(red)
(cond
[(no-special-in-content? 9)
(path (subbytes bstr 8) 'windows)]
[else p])]
[(rel)
(define-values (dots-end literal-start) (backslash-backslash-questionmark-dot-ups-end bstr len))
(cond
[(no-special-in-content? literal-start)
;; Remove any extra backslash for `dots-end`
(path (bytes-append (if dots-end (subbytes bstr 8 (add1 dots-end)) #"")
(subbytes bstr literal-start))
'windows)]
[else p])]
[else p]))
(define (normalize-backslash-backslash-unc bstr)
;; Normalize "UNC" case and single \ after \\?
(cond
[(and (eqv? (bytes-ref bstr 4) (char->integer #\U))
(eqv? (bytes-ref bstr 5) (char->integer #\N))
(eqv? (bytes-ref bstr 6) (char->integer #\C)))
bstr]
[(eqv? (bytes-ref bstr 4) (char->integer #\\))
(bytes-append #"\\\\?\\UNC" (subbytes bstr 8))]
[else
(bytes-append #"\\\\?\\UNC" (subbytes bstr 7))]))

230
racket/src/io/path/split.rkt
View File

@ -32,40 +32,39 @@
[(and ((bytes-length bstr) . > . 2)
(is-sep? (bytes-ref bstr 0) 'windows)
(is-sep? (bytes-ref bstr 1) 'windows))
(define-values (//?-kind //?-drive-end) (parse-//?-drive bstr))
(define-values (//?-kind //?-drive-end //?-orig-drive-end) (parse-//?-drive bstr))
(cond
[//?-kind
(define allow-double-before //?-drive-end)
(cond
[(or (eq? //?-kind 'rel)
(eq? //?-kind 'red))
[(or (eq? //?-kind 'rel)
(eq? //?-kind 'red))
;; `\\?\REL\` or `\\?\RED\` path. Handle it directly as a special case
(split-reld bstr)]
(split-reld bstr #:explode? explode?)]
[else
(split-after-drive p
#:drive-end (cond
[(and (//?-drive-end . < . (bytes-length bstr))
(eq? (bytes-ref bstr //?-drive-end) (char->integer #\\)))
;; Happens with \\?\c:\\, for example
(add1 //?-drive-end)]
[else //?-drive-end])
#:drive-end //?-orig-drive-end
#:keep-drive-end (if (eq? //?-kind 'unc)
//?-orig-drive-end
//?-drive-end)
#:allow-double-before //?-orig-drive-end
#:no-slash-sep? #t
#:no-up? #t
#:explode? explode?)])]
[else
(define //-drive-end (parse-//-drive bstr))
(cond
[//-drive-end
(split-after-drive p
#:drive-end (cond
[(and (//-drive-end . < . (bytes-length bstr))
(is-sep? (bytes-ref bstr //?-drive-end) 'windows))
(add1 //-drive-end)]
[else //-drive-end])
#:allow-double-before 1
#:explode? explode?)]
[else
(split-after-drive p #:explode? explode?)])])]
[//-drive-end
(split-after-drive p
#:drive-end (cond
[(and (//-drive-end . < . (bytes-length bstr))
(is-sep? (bytes-ref bstr //-drive-end) 'windows))
(add1 //-drive-end)]
[else //-drive-end])
#:allow-double-before 1
#:explode? explode?)]
[else
(split-after-drive p #:explode? explode?)])])]
[(and ((bytes-length bstr) . > . 2)
(drive-letter? (bytes-ref bstr 0))
(eq? (bytes-ref bstr 1) (char->integer #\:)))
@ -85,6 +84,7 @@
(define (split-after-drive p
#:len [in-len #f]
#:drive-end [drive-end 0]
#:keep-drive-end [keep-drive-end drive-end]
#:no-slash-sep? [no-slash-sep? #f]
#:no-up? [no-up? #f]
#:allow-double-before [allow-double-before 0]
@ -101,21 +101,25 @@
(define-values (split-pos ends-sep?)
(let loop ([i (sub1 len)] [ends-sep? #f])
(cond
[(i . < . drive-end) (values #f ends-sep?)]
[else
(define sep?
(cond
[no-slash-sep? (eq? (bytes-ref bstr i) #\\)]
[else (is-sep? (bytes-ref bstr i) convention)]))
(cond
[sep?
(if (i . < . (sub1 len))
(values i ends-sep?)
(loop (sub1 i) #t))]
[else
(loop (sub1 i) ends-sep?)])])))
[(i . < . drive-end)
(if (and (positive? i)
(i . < . (sub1 len)))
(values i ends-sep?)
(values #f ends-sep?))]
[else
(define sep?
(cond
[no-slash-sep? (eq? (bytes-ref bstr i) (char->integer #\\))]
[else (is-sep? (bytes-ref bstr i) convention)]))
(cond
[sep?
(if (i . < . (sub1 len))
(values i ends-sep?)
(loop (sub1 i) #t))]
[else
(loop (sub1 i) ends-sep?)])])))
;; The `split-pos` argument is #f or less than `(sub1 len)`
(cond
[(not split-pos)
;; No splitting available: relative or exactly a root
@ -153,12 +157,16 @@
[else
(values base name is-dir?)])]
[else
;; Is it possible that by removing the last path element, we'll leave
;; a directory path that needs conversion to \\?\ on Windows? I think
;; not, because even if the remaining path ends in spaces and "."s, the
;; path separator will stay in place to make the trailing spaces and
;; "."s significant.
(define-values (exposed-bstr exposed-len) (values bstr (add1 split-pos)))
;; Is it possible that by removing the last path element, we'll
;; leave a directory path that needs conversion to \\?\ on
;; Windows? No: even if the remaining path ends in spaces and
;; "."s, the path separator will stay in place to make the
;; trailing spaces and "."s significant.
(define-values (exposed-bstr exposed-len) (values bstr
(let ([len (add1 split-pos)])
(if (= len drive-end)
keep-drive-end
len))))
(cond
[explode?
(cons name
@ -166,6 +174,7 @@
#:explode? #t
#:len exposed-len
#:drive-end drive-end
#:keep-drive-end keep-drive-end
#:no-slash-sep? no-slash-sep?
#:no-up? no-up?
#:allow-double-before allow-double-before))]
@ -218,73 +227,86 @@
(define (parse-//?-drive bstr)
(define-values (kind drive-len orig-drive-len clean-start-pos add-sep-pos)
(parse-backslash-backslash-questionmark bstr))
(values kind drive-len))
(values kind drive-len orig-drive-len))
(define (parse-//-drive bstr)
(parse-unc bstr 0))
;; Splits a \\?\REL or \\?\RED path
(define (split-reld bstr)
(define-values (len is-dir?)
(let ([len (bytes-length bstr)])
(cond
[(eqv? (bytes-ref bstr (sub1 len)) (char->integer #\\))
(values (sub1 len) #t)]
[else
(values len #f)])))
(define-values (dots-end literal-start)
(backslash-backslash-questionmark-dot-ups-end bstr len))
(cond
[(literal-start . < . len)
;; There's at least one literal path
(let loop ([p (sub1 len)])
(cond
[(p . <= . (if dots-end (sub1 literal-start) literal-start))
;; One one element and no dots
(cond
[(eqv? (bytes-ref bstr 6) (char->integer #\L))
;; keep \\?\REL\ on path, and report 'relative as base */
(values 'relative
(path (if is-dir? (subbytes bstr 0 len) bstr) 'windows)
is-dir?)]
[else
;; Switch "D" to "L", and simplify base to just "\\"
(values (path #"\\" 'windows)
(path
(bytes-append #"\\\\?\\REL\\"
(if (eqv? (bytes-ref bstr 8) (char->integer #\\))
#""
#"\\")
(subbytes bstr 8))
'windows)
is-dir?)])]
[(eqv? (bytes-ref bstr p) (char->integer #\\))
;; Prefix path element with \\?\REL\\
(define elem-bstr
(bytes-append #"\\\\?\\REL\\\\"
(subbytes bstr (add1 p) len)))
(define nsep
(define (split-reld bstr #:explode? explode?)
(let explode-loop ([bstr bstr])
(define-values (len is-dir?)
(let ([len (bytes-length bstr)])
(cond
[(eqv? (bytes-ref bstr (sub1 len)) (char->integer #\\))
(values (sub1 len) #t)]
[else
(values len #f)])))
(define-values (dots-end literal-start)
(backslash-backslash-questionmark-dot-ups-end bstr len))
(cond
[(literal-start . < . len)
;; There's at least one literal path
(let loop ([p (sub1 len)])
(cond
[(p . < . (if dots-end (sub1 literal-start) literal-start))
;; One one element and no dots
(cond
[(or (eqv? dots-end p) (eqv? dots-end (sub1 p)))
;; stripping the only element: drop reundant separator(s) after ..
(if (eqv? dots-end p) 0 -1)]
[(eqv? (bytes-ref bstr 6) (char->integer #\L))
;; preserve separator
1]
;; preserve one separator, but not two
[(eqv? (bytes-ref bstr (sub1 p)) (char->integer #\\))
0]
[else 1]))
(values (path (subbytes bstr 0 (+ p nsep)) 'windows)
(path elem-bstr 'windows)
is-dir?)]
[else (loop (sub1 p))]))]
[else
;; There are no literals --- just dots
(cond
[((- dots-end 3) . > . 8)
(values (path (subbytes bstr 0 (- dots-end 3)) 'windows)
'up
#t)]
[else
(values 'relative 'up #t)])]))
;; keep \\?\REL\ on path, and report 'relative as base */
(define elem (path (if is-dir? (subbytes bstr 0 len) bstr) 'windows))
(cond
[explode? (list elem)]
[else (values 'relative
elem
is-dir?)])]
[else
;; Switch "D" to "L", and simplify base to just "\\"
(define base (path #"\\" 'windows))
(define elem (path
(bytes-append #"\\\\?\\REL\\"
(if (eqv? (bytes-ref bstr 8) (char->integer #\\))
#""
#"\\")
(subbytes bstr 8))
'windows))
(cond
[explode? (list elem base)]
[else (values base elem is-dir?)])])]
[(eqv? (bytes-ref bstr p) (char->integer #\\))
;; Prefix path element with \\?\REL\\
(define elem-bstr
(bytes-append #"\\\\?\\REL\\\\"
(subbytes bstr (add1 p) len)))
(define nsep
(cond
[(or (eqv? dots-end p) (eqv? dots-end (sub1 p)))
;; stripping the only element: drop reundant separator(s) after ..
(if (eqv? dots-end p) 0 -1)]
[(eqv? (bytes-ref bstr 6) (char->integer #\L))
;; preserve separator
1]
;; preserve one separator, but not two
[(eqv? (bytes-ref bstr (sub1 p)) (char->integer #\\))
0]
[else 1]))
(define base-bstr (subbytes bstr 0 (+ p nsep)))
(define elem (path elem-bstr 'windows))
(cond
[explode? (cons elem (explode-loop base-bstr))]
[else (values (path base-bstr 'windows) elem is-dir?)])]
[else (loop (sub1 p))]))]
[else
;; There are no literals --- just dots
(cond
[explode?
(let loop ([dots-end dots-end])
(cond
[(dots-end . > . 9) (cons 'up (loop (- dots-end 3)))]
[else '()]))]
[((- dots-end 3) . > . 8)
(values (path (subbytes bstr 0 (- dots-end 3)) 'windows)
'up
#t)]
[else
(values 'relative 'up #t)])])))

54
racket/src/io/path/windows.rkt
View File

@ -10,7 +10,8 @@
parse-unc
backslash-backslash-questionmark-dot-ups-end
split-drive
strip-trailing-spaces)
strip-trailing-spaces
strip-backslash-backslash-rel)
(define special-filenames
;; and "CLOCK$" on NT --- but not traditionally detected by Racket
@ -76,7 +77,7 @@
(eqv? (bytes-ref bstr 2) (char->integer #\?))
(eqv? (bytes-ref bstr 3) (char->integer #\\))))
;; Returns #f, 'rel, 'red, or 'abs
;; Returns #f, 'rel, 'red, 'unc, or 'abs
(define (backslash-backslash-questionmark-kind bstr)
(define-values (kind drive-end-pos orig-drive-end-pos clean-start-pos add-sep-pos)
(parse-backslash-backslash-questionmark bstr))
@ -94,7 +95,8 @@
;;
;; The `orig-drive-len` result is almost the same as `drive-len`,
;; but maybe longer. It preserves an artifact of the given specification:
;; a backslash after a \\?\UNC\<mahine>\<volume> drive.
;; a backslash after a \\?\UNC\<mahine>\<volume> drive, an extra
;; backslash after a \\?\<letter>:\ drive, etc.
;;
;; For 'abs, `clean-start-pos` is the position where it's ok to start
;; removing extra slashes. It's usually the same as `drive-len`. In
@ -156,18 +158,19 @@
(loop i))])))
=> (lambda (i)
(define i+1 (add1 i))
(values 'abs i+1 i+1 i+1 #""))]
(values 'abs i i+1 i+1 #""))]
;; Check for drive-letter case
[(and (len . > . 6)
(drive-letter? (bytes-ref bstr base))
(eqv? (bytes-ref bstr (add1 base)) (char->integer #\:))
(len . > . (+ 2 base))
(eqv? (bytes-ref bstr (+ 2 base)) (char->integer #\\)))
(define drive-len (if (and (len . > . (+ 3 base))
(eqv? (bytes-ref bstr (+ 3 base)) (char->integer #\\)))
(+ base 4)
(+ base 3)))
(values 'abs drive-len drive-len (+ base 2) #"")]
(define drive-len (+ base 3))
(define orig-drive-len (if (and (len . > . drive-len)
(eqv? (bytes-ref bstr drive-len) (char->integer #\\)))
(add1 drive-len)
drive-len))
(values 'abs drive-len orig-drive-len (+ base 2) #"")]
;; Check for UNC
[(and (len . > . (+ base 3))
(let ([b (bytes-ref bstr base)])
@ -188,7 +191,7 @@
(eqv? (bytes-ref bstr drive-len) (char->integer #\\)))
(add1 drive-len)
drive-len))
(values 'abs drive-len orig-drive-len (+ base 3) #"\\"))]
(values 'unc drive-len orig-drive-len (+ base 3) #"\\"))]
;; Check for REL and RED
[(and (= base 4)
(len . > . 8)
@ -209,6 +212,14 @@
#f)]
;; Otherwise, \\?\ is the (non-existent) drive
[else
;; Can have up to two separators between the drive and first element
(define orig-drive-len (if (and (len . > . 4)
(eqv? (bytes-ref bstr 4) (char->integer #\\)))
(if (and (len . > . 5)
(eqv? (bytes-ref bstr 5) (char->integer #\\)))
6
5)
4))
(define clean-start-pos
(if (or (and (= len 5)
(eqv? (bytes-ref bstr 4) (char->integer #\\)))
@ -216,8 +227,8 @@
(eqv? (bytes-ref bstr 4) (char->integer #\\))
(eqv? (bytes-ref bstr 5) (char->integer #\\))))
3
4))
(values 'abs 4 4 clean-start-pos #"\\\\")])]))
orig-drive-len))
(values 'abs 4 orig-drive-len clean-start-pos #"\\\\")])]))
;; Returns an integer if this path is a UNC path, #f otherwise.
;; If `delta` is non-0, then `delta` is after a leading \\.
@ -286,6 +297,11 @@
;; We have //?/, with up to 2 backslashes.
;; This doesn't count as UNC, to avoid confusion with \\?\.
#f]
[(and (not no-forward-slash?)
(j . < . len)
(is-a-sep? (bytes-ref bstr j)))
;; Extra backslash not allowed after //<machine>/<drive> when not in \\?\ mode
#f]
[else
(let loop ([j j])
(cond
@ -356,7 +372,6 @@
[else
(values #f 8)]))
(define (split-drive bstr)
(cond
[(backslash-backslash-questionmark? bstr)
@ -382,7 +397,9 @@
(define i (sub1 i+1))
(cond
[(is-sep? (bytes-ref bstr i) 'windows)
(loop i)]
(if (zero? i)
0
(loop i))]
[else i+1])))
(let loop ([i+1 len-before-seps])
(cond
@ -406,3 +423,12 @@
;; Trim
(bytes-append (subbytes bstr 0 i+1)
(subbytes bstr len-before-seps len))])]))]))
(define (strip-backslash-backslash-rel bstr)
(define-values (kind drive-end-pos orig-drive-end-pos clean-start-pos add-sep-pos)
(parse-backslash-backslash-questionmark bstr))
(case kind
[(rel) (subbytes bstr (if (eqv? (bytes-ref bstr 8) (char->integer #\\))
9
8))]
[else bstr]))

46
racket/src/racket/src/file.c
View File

@ -565,48 +565,8 @@ static Scheme_Object *make_protected_path(char *chars)
Scheme_Object *make_exposed_sized_offset_path(int *optional, int already_protected,
char *chars, intptr_t d, intptr_t len, int copy,
int kind)
/* Called to make a directory path where the end has been removed.
We may need to remove a redundant separator.
Under Windows, if the resulting last element has spaces or is a
special file, then we need to protect it with "\\?\". */
/* Called to make a directory path where the end has been removed. */
{
if (kind == SCHEME_WINDOWS_PATH_KIND) {
if (!already_protected) {
int i, name_end;
int non_dot = 0, trailing_dots = 0, protect = 0;
/* Skip trailing seps: */
for (i = d + len - 1; (i > d) && IS_A_DOS_SEP(chars[i]); --i) {
}
name_end = i+1;
for (; (i > d) && !IS_A_DOS_SEP(chars[i]); --i) {
if ((chars[i] != ' ') && (chars[i] != '.'))
non_dot = 1;
else if (!non_dot)
trailing_dots = 1;
}
if (non_dot && trailing_dots)
protect = 1;
else if (name_end == (d + len))
protect = is_special_filename(chars, i+1, name_end, 0, 1);
if (protect) {
Scheme_Object *first, *last, *a[2];
char *s2;
int l;
l = name_end - (i+1);
s2 = (char *)scheme_malloc_atomic(l + 9 + 1);
memcpy(s2, "\\\\?\\REL\\\\", 9);
memcpy(s2+9, chars + i + 1, l);
s2[l + 9] = 0;
last = scheme_make_sized_offset_kind_path(s2, 0, l+9, 0, SCHEME_WINDOWS_PATH_KIND);
first = make_exposed_sized_offset_path(NULL, 0, chars, d, i-d+1, 1, SCHEME_WINDOWS_PATH_KIND);
a[0] = first;
a[1] = last;
return scheme_build_path(2, a);
}
}
}
/* We may need to remove a redundant separator from the directory
path. Try removing it, and see if anyone would care: */
if (do_path_to_directory_path(chars, d, len - 1, scheme_true, 1, kind)) {
@ -1443,9 +1403,9 @@ char *strip_trailing_spaces(const char *s, int *_len, int delta, int in_place)
else
len = strlen(s);
/* Keep separators that are at the very end: */
/* Don't strip before a separator: */
if ((len - skip_end > delta) && IS_A_DOS_SEP(s[len - 1 - skip_end])) {
skip_end++;
return (char *)s;
}
if ((len - skip_end > delta)

17
racket/src/worksp/csbuild.rkt
View File

@ -2,25 +2,34 @@
(require racket/cmdline
racket/path
racket/file
racket/runtime-path
compiler/find-exe
racket/system
"cs/prep.rkt")
(define scheme-dir "..\\build\\ChezScheme")
(define-runtime-path here ".")
(define abs-scheme-dir (build-path here 'up "build" "ChezScheme"))
(define machine (if (= 32 (system-type 'word))
"ti3nt"
"ta6nt"))
(command-line
#:once-each
[("--scheme-dir") dir "Select the Chez Scheme build directory"
(set! scheme-dir dir)]
[("--scheme-dir") dir "Select the Chez Scheme build directory, unless <dir> is \"\""
(unless (equal? dir "")
(set! abs-scheme-dir (path->complete-path dir)))]
[("--machine") mach "Select the Chez Scheme machine name"
(set! machine mach)]
#:args
()
(void))
(current-directory here)
(define scheme-dir (find-relative-path (current-directory)
(simplify-path abs-scheme-dir)))
(define (system*! prog . args)
(printf "{in ~a}\n" (current-directory))
(printf "~a" prog)
@ -81,7 +90,7 @@
(system*! "nmake"
(format "~a-src-generate" name)
(format "BUILDDIR=~a" build-dir)
(format "RACKET=~a ~a ~a" chain-racket "ignored" "ignored.d")))))
(format "RACKET=~a ~a ~a" chain-racket "ignored" (build-path build-dir "compiled/ignored.d"))))))
(build-layer "expander")
(build-layer "thread")