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

23
Makefile
View File

@ -86,7 +86,10 @@ in-place-setup:
win32-in-place: win32-in-place:
$(MAKE) win32-base $(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 update $(UPDATE_PKGS_ARGS)
$(WIN32_RUN_RACO) pkg install $(INSTALL_PKGS_ARGS) $(WIN32_RUN_RACO) pkg install $(INSTALL_PKGS_ARGS)
$(WIN32_RUN_RACO) setup --only-foreign-libs $(ALL_PLT_SETUP_OPTIONS) $(WIN32_RUN_RACO) setup --only-foreign-libs $(ALL_PLT_SETUP_OPTIONS)
@ -284,6 +287,24 @@ racket/src/build/ChezScheme:
update-ChezScheme: update-ChezScheme:
cd racket/src/build/ChezScheme && git pull && git submodule update 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 # 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 #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 (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 #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 "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 "x/../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 "../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 "\\\\?\\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/") (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 "../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/")) (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 #"\\\\?\\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 #"\\\\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 #"\\\\?\\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)
(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 (string->path-element "Apple"))
(test "Apple" path-element->string (bytes->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 (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 #".." 'unix)) (err/rt-test (bytes->path-element #".." 'unix))
(err/rt-test (bytes->path-element "a/b" '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 (unless cross-system-table
(define lib-dir (find-lib-dir)) (define lib-dir (find-lib-dir))
(define ht (and 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")]) (let ([f (build-path lib-dir "system.rktd")])
(and (file-exists? f) (and (file-exists? f)
(let ([ht (call-with-default-reading-parameterization (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 This directory implements the port, path, encoding, printing, and
formatting layer. It can be run in a host Racket with `make demo`, but formatting layer. It can be run in a host Racket with `make demo`,
it's meant to be compiled for use in Racket on Chez Scheme; see which is useful for development and debugging, but it's meant to be
"../cs/README.txt". compiled for use in Racket on Chez Scheme; see "../cs/README.txt".
Core error support must be provided as a more primitive layer, Core error support must be provided as a more primitive layer,
including the exception structures and error functions that do not 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 #lang racket/base
(require "../locale/string.rkt" (require "../locale/string.rkt"
"../format/main.rkt"
"check.rkt" "check.rkt"
"path.rkt" "path.rkt"
"sep.rkt" "sep.rkt"
@ -26,8 +27,9 @@
(check-build-path-arg who sub) (check-build-path-arg who sub)
(loop (argument->convention sub convention who #:first? #f) (loop (argument->convention sub convention who #:first? #f)
(cdr subs))]))) (cdr subs))])))
(path (append-path-parts convention who base subs) (define final-convention (or convention (system-path-convention-type)))
convention)) (path (append-path-parts final-convention who base subs)
final-convention))
;; ---------------------------------------- ;; ----------------------------------------
@ -58,7 +60,7 @@
(cond (cond
[(path? p) (check (path-convention p))] [(path? p) (check (path-convention p))]
[(string? p) (check (system-path-convention-type))] [(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) (convert-to-initial-backslash-backslash-questionmark bstr)
(list (strip-trailing-spaces bstr)))] (list (strip-trailing-spaces bstr)))]
[else (list 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 ;; The `accum` list accumulates byte strings in reverse order to be
;; appended. On Windows in \\?\ mode, each byte string corresponds ;; appended. On Windows in \\?\ mode, each byte string corresponds
;; to a single path element with a leading backslash, except that ;; 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 ;; be a mixture of compound path elements and separators
(let loop ([accum base-accum] [subs subs] [first? #t]) (let loop ([accum base-accum] [subs subs] [first? #t])
(cond (cond
[(null? subs) [(null? subs)
(define elems (reverse accum)) (define elems (reverse accum))
(combine-build-elements elems)] (combine-build-elements elems unc-result?)]
[else [else
(define sub (car subs)) (define sub (car subs))
(define bstr (as-bytes sub)) (define bstr (as-bytes sub))
@ -116,7 +122,7 @@
(raise-arguments-error who (raise-arguments-error who
(string-append what " cannot be added to a base path") (string-append what " cannot be added to a base path")
what sub what sub
"base path" (path (combine-build-elements (reverse accum)) "base path" (path (combine-build-elements (reverse accum) unc-result?)
'windows))) 'windows)))
(loop (combine-windows-path (if (and (null? subs) (loop (combine-windows-path (if (and (null? subs)
;; because \\?\ mode does its own stripping: ;; because \\?\ mode does its own stripping:
@ -124,7 +130,8 @@
bstr bstr
(strip-trailing-spaces bstr)) (strip-trailing-spaces bstr))
accum accum
result-is-backslash-backslash-questionmark?) result-is-backslash-backslash-questionmark?
(null? (cdr subs)))
(cdr subs) (cdr subs)
#f)) #f))
(cond (cond
@ -133,9 +140,10 @@
[(backslash-backslash-questionmark? bstr) [(backslash-backslash-questionmark? bstr)
(define-values (kind drive-len orig-drive-len clean-start-pos add-sep-pos) (define-values (kind drive-len orig-drive-len clean-start-pos add-sep-pos)
(parse-backslash-backslash-questionmark bstr)) (parse-backslash-backslash-questionmark bstr))
(define abs? (or (eq? kind 'abs) (eq? kind 'unc)))
(combine (eq? kind 'rel) (combine (eq? kind 'rel)
(eq? kind 'abs) abs?
(and (eq? kind 'abs) (and abs?
(just-backslashes-after? bstr drive-len)))] (just-backslashes-after? bstr drive-len)))]
[(parse-unc bstr 0) [(parse-unc bstr 0)
=> (lambda (drive-len) => (lambda (drive-len)
@ -147,27 +155,31 @@
[else [else
(combine #t #f #f)])])]))) (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 (cond
[result-is-backslash-backslash-questionmark? [result-is-backslash-backslash-questionmark?
;; Split `bstr` into pieces, and handle the pieces one-by-one ;; 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 (cond
[(null? elems) accum] [(null? elems)
(if (and is-last? to-dir? (pair? (cdr accum)))
(cons (bytes-append (car accum) #"\\") (cdr accum))
accum)]
[else [else
(define sub (car elems)) (define sub (car elems))
(cond (cond
[(eq? 'same sub) [(eq? 'same sub)
;; Ignore 'same for \\?\ mode ;; Ignore 'same for \\?\ mode
(loop (cdr elems) accum)] (loop (cdr elems) accum #t)]
[(eq? 'up sub) [(eq? 'up sub)
;; Drop previous element for 'up in \\?\ mode ;; Drop previous element for 'up in \\?\ mode
(loop (cdr elems) (loop (cdr elems)
(if (null? (cdr accum)) (if (null? (cdr accum))
(list (starting-point-add-up (car accum))) (list (starting-point-add-up (car accum)))
(cdr accum)))] (cdr accum))
#t)]
[else [else
(loop (cdr elems) (cons sub accum))])]))] (loop (cdr elems) (cons sub accum) #f)])]))]
[else [else
;; Not in \\?\ mode, so `bstr` must not be a \\?\ path. ;; Not in \\?\ mode, so `bstr` must not be a \\?\ path.
;; In case `accum` is drive-relative, start by dropping any ;; In case `accum` is drive-relative, start by dropping any
@ -189,16 +201,18 @@
new-accum new-accum
(cons sub new-accum))])) (cons sub new-accum))]))
(define (windows-split-into-path-elements bstr) (define (windows-split-into-path-elements bstr keep-trailing-separator?)
(cond (cond
[(backslash-backslash-questionmark? bstr) [(backslash-backslash-questionmark? bstr)
;; It must be REL or RED (with only a drive to build on) ;; It must be REL or RED (with only a drive to build on)
(define-values (dots-end literal-start) (define-values (dots-end literal-start)
(backslash-backslash-questionmark-dot-ups-end bstr (bytes-length bstr))) (backslash-backslash-questionmark-dot-ups-end bstr (bytes-length bstr)))
(append (extract-dot-ups bstr 8 (or dots-end 8)) (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 [else
(extract-separate-parts bstr 0)])) (extract-separate-parts bstr 0 #:keep-trailing-separator? keep-trailing-separator?)]))
(define (as-bytes p) (define (as-bytes p)
(cond (cond
@ -227,23 +241,25 @@
[(letter-drive-start? s (bytes-length s)) [(letter-drive-start? s (bytes-length s))
(just-separators-after? s 2)])) (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 len ; number of bytes to use when adding more element
orig-len ; number of bytes to use when not adding more elements orig-len ; number of bytes to use when not adding more elements
extra-sep ; extra separator before first added element extra-sep ; extra separator before first added element
add-ups? ; whether to add `up`s to the base string, as opposed to dropping them add-ups? ; whether to add `up`s to the base string, as opposed to dropping them
drive?)) ; is bstr an absolute root? drive?)) ; is bstr an absolute root?
(define (make-starting-point bstr (define (make-starting-point kind
bstr
len len
#:orig-len [orig-len len] #:orig-len [orig-len len]
#:extra-sep [extra-sep #""] #:extra-sep [extra-sep #""]
#:add-ups? [add-ups? #f] #:add-ups? [add-ups? #f]
#:drive? [drive? #t]) #:drive? [drive? #t])
(list (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 (cond
[(starting-point? (car elems)) [(starting-point? (car elems))
;; in \\?\ mode for Windows ;; in \\?\ mode for Windows
@ -258,23 +274,38 @@
#"."] #"."]
[(equal? bstr #"\\\\?\\RED") [(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 [else
(define init-bstr (subbytes (starting-point-bstr s) (define init-bstr (subbytes (starting-point-bstr s)
0 0
(starting-point-len s))) (starting-point-len s)))
(define rel-..-special-case? (and (bytes=? init-bstr #"\\\\?\\REL")
(bytes=? (cadr elems) #"\\..")))
(apply bytes-append (apply bytes-append
init-bstr 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) (starting-point-extra-sep s)
(cdr elems))])] (cdr elems))])]
[else [else
;; simple case ;; simple case...
(apply bytes-append elems)])) (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) (define (convert-to-initial-backslash-backslash-questionmark bstr)
(cond (cond
@ -282,19 +313,19 @@
(define-values (kind drive-len orig-drive-len clean-start-pos add-sep) (define-values (kind drive-len orig-drive-len clean-start-pos add-sep)
(parse-backslash-backslash-questionmark bstr)) (parse-backslash-backslash-questionmark bstr))
(case kind (case kind
[(abs) [(abs unc)
(append (reverse (extract-separate-parts bstr drive-len #:bbq-mode? #t)) (append (reverse (extract-separate-parts bstr drive-len #:bbq-mode? #t))
(if (equal? add-sep #"") (if (equal? add-sep #"")
;; drop implicit terminator in drive: ;; drop implicit terminator in drive:
(make-starting-point bstr (sub1 drive-len) #:orig-len orig-drive-len) (make-starting-point kind 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 drive-len #:orig-len orig-drive-len #:extra-sep (subbytes add-sep 1))))]
[else [else
;; We can't back up over any dots before `dots-end`, ;; We can't back up over any dots before `dots-end`,
;; so keep those toegether with \\?\REL ;; so keep those toegether with \\?\REL
(define-values (dots-end literal-start) (define-values (dots-end literal-start)
(backslash-backslash-questionmark-dot-ups-end bstr (bytes-length bstr))) (backslash-backslash-questionmark-dot-ups-end bstr (bytes-length bstr)))
(append (reverse (extract-separate-parts bstr literal-start #:bbq-mode? #t)) (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) [(parse-unc bstr 0)
=> (lambda (root-len) => (lambda (root-len)
(define-values (machine volume) (define-values (machine volume)
@ -303,23 +334,23 @@
(append (reverse (simplify-dots (extract-separate-parts bstr root-len) #:drop-leading? #t)) (append (reverse (simplify-dots (extract-separate-parts bstr root-len) #:drop-leading? #t))
(let* ([unc-bstr (bytes-append #"\\\\?\\UNC" machine volume)] (let* ([unc-bstr (bytes-append #"\\\\?\\UNC" machine volume)]
[unc-len (bytes-length unc-bstr)]) [unc-len (bytes-length unc-bstr)])
(make-starting-point unc-bstr unc-len))))] (make-starting-point 'unc unc-bstr unc-len))))]
[(bytes=? #"." bstr) [(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) [(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) [(is-sep? (bytes-ref bstr 0) 'windows)
(append (reverse (extract-separate-parts bstr 0)) (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) [(and ((bytes-length bstr) . >= . 2)
(drive-letter? (bytes-ref bstr 0)) (drive-letter? (bytes-ref bstr 0))
(eqv? (bytes-ref bstr 1) (char->integer #\:))) (eqv? (bytes-ref bstr 1) (char->integer #\:)))
(append (reverse (simplify-dots (extract-separate-parts bstr 2) #:drop-leading? #t)) (append (reverse (simplify-dots (extract-separate-parts bstr 2) #:drop-leading? #t))
(let ([drive-bstr (bytes-append #"\\\\?\\" (subbytes bstr 0 2) #"\\")]) (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 [else
;; Create \\?\REL, combinding any leading dots into the \\?\REL part: ;; 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]) (let loop ([dots null] [elems elems])
(cond (cond
[(or (null? elems) [(or (null? elems)
@ -327,13 +358,15 @@
(append (reverse elems) (append (reverse elems)
(let* ([rel-bstr (apply bytes-append #"\\\\?\\REL" dots)] (let* ([rel-bstr (apply bytes-append #"\\\\?\\REL" dots)]
[rel-len (bytes-length rel-bstr)]) [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 [else
(loop (cons (car elems) dots) (cdr elems))]))])) (loop (cons (car elems) dots) (cdr elems))]))]))
;; Split on separators, removing trailing whitespace from the last ;; Split on separators, removing trailing whitespace from the last
;; element, and prefix each extracted element with a backslash: ;; 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) (define (is-a-sep? b)
(if bbq-mode? (if bbq-mode?
(eqv? b (char->integer #\\)) (eqv? b (char->integer #\\))
@ -363,7 +396,11 @@
(bytes=? new-bstr #"..")) (bytes=? new-bstr #".."))
'up] 'up]
[else [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)] (cons new-sub rest)]
[else (e-loop (add1 end-pos))]))]))) [else (e-loop (add1 end-pos))]))])))
@ -399,10 +436,10 @@
(let loop ([bstrs bstrs] [accum null]) (let loop ([bstrs bstrs] [accum null])
(cond (cond
[(null? bstrs) (reverse accum)] [(null? bstrs) (reverse accum)]
[(eq? 'up (car bstrs)) (loop (cdr bstrs) accum)] [(eq? 'same (car bstrs)) (loop (cdr bstrs) accum)]
[(eq? 'same (car bstrs)) (if (null? accum) [(eq? 'up (car bstrs)) (if (null? accum)
(if drop-leading? (if drop-leading?
(loop (cdr bstrs) accum) (loop (cdr bstrs) accum)
(loop (cdr bstrs) (cons (car bstrs) accum))) (loop (cdr bstrs) (cons (car bstrs) accum)))
(loop (cdr bstrs) (cdr accum)))] (loop (cdr bstrs) (cdr accum)))]
[else (loop (cdr bstrs) (cons (car bstrs) 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 #\\)))) (eqv? (bytes-ref bstr (- literal-start 2)) (char->integer #\\))))
(cond (cond
[has-extra-backslash? (return new-bstr)] [has-extra-backslash? (return new-bstr)]
[(= literal-start (bytes-length new-bstr)) (return new-bstr)]
[else [else
(return (bytes-append (subbytes new-bstr 0 literal-start) (return (bytes-append (subbytes new-bstr 0 literal-start)
#"\\" #"\\"
(subbytes new-bstr literal-start)))])])] (subbytes new-bstr literal-start)))])])]
[(parse-unc bstr 0) [(parse-unc bstr 0)
=> (lambda (drive-len) => (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)) [(letter-drive-start? bstr (bytes-length bstr))
(cond (cond
[(and ((bytes-length bstr) . > . 2) [(and ((bytes-length bstr) . > . 2)
(is-sep? (bytes-ref bstr 2) 'windows)) (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 [else
(return (bytes-append (subbytes bstr 0 2) (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 [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 (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) (define (is-a-sep? b)
(if only-backslash? (if only-backslash?
(eqv? b (char->integer #\\)) (eqv? b (char->integer #\\))
@ -77,18 +83,36 @@
(add1 (loop (sub1 i)))] (add1 (loop (sub1 i)))]
[else (loop (sub1 i))]))) [else (loop (sub1 i))])))
(cond (cond
[(zero? extra-count) [(and (zero? extra-count)
bstr] (or (not to-backslash-from)
[else (not (for/or ([b (in-bytes bstr to-backslash-from)])
(define new-bstr (make-bytes (- (bytes-length bstr) extra-count))) (eq? b (char->integer #\/))))))
(let loop ([i (sub1 (bytes-length bstr))] [j (sub1 (bytes-length new-bstr))]) bstr]
(unless (i . <= . allow-double-before) [else
(cond (define new-bstr (make-bytes (- (bytes-length bstr) extra-count)))
[(and (is-a-sep? (bytes-ref bstr i)) (let loop ([i (sub1 (bytes-length bstr))] [j (sub1 (bytes-length new-bstr))])
(is-a-sep? (bytes-ref bstr (sub1 i)))) (unless (i . <= . allow-double-before)
(loop (sub1 i) j)] (cond
[else [(is-a-sep? (bytes-ref bstr i))
(bytes-set! new-bstr j (bytes-ref bstr i)) (cond
(loop (sub1 i) (sub1 j))]))) [(is-a-sep? (bytes-ref bstr (sub1 i)))
(bytes-copy! new-bstr 0 bstr 0 (add1 allow-double-before)) (loop (sub1 i) j)]
new-bstr])) [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 #\\)) (or (eqv? (bytes-ref bstr (sub1 len)) (char->integer #\\))
(and (not require-sep?) (and (not require-sep?)
(eq? 'rel (backslash-backslash-questionmark-kind bstr)) (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?)])])) [else (unixish-path-directory-path?)])]))
(define (path->path-without-trailing-separator p) (define (path->path-without-trailing-separator p)

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

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

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

@ -16,7 +16,12 @@
#:property prop:custom-write #:property prop:custom-write
(lambda (p port mode) (lambda (p port mode)
(when 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) (write-string (bytes->string/locale (path-bytes p)) port)
(when mode (when mode
(write-string ">" port))) (write-string ">" port)))

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

@ -10,7 +10,8 @@
"cleanse.rkt" "cleanse.rkt"
"directory-path.rkt" "directory-path.rkt"
"complete.rkt" "complete.rkt"
"parameter.rkt") "parameter.rkt"
"windows.rkt")
(provide simplify-path) (provide simplify-path)
@ -18,78 +19,92 @@
(check-path-argument who p-in) (check-path-argument who p-in)
(define p (->path p-in)) (define p (->path p-in))
(define convention (path-convention p)) (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 (cond
[(simple? p convention) p] [(simple? p convention) p]
[else [else
(define clean-p (cleanse-path p)) (define clean-p (cleanse-path p))
(cond (cond
[(simple? clean-p convention) clean-p] [(simple? clean-p convention) clean-p]
[else [else
(define l (explode-path clean-p)) (define l (explode-path clean-p))
(define simple-p (define simple-p
(cond (cond
[use-filesystem? [use-filesystem?
;; Use the filesystem, which requires building ;; Use the filesystem, which requires building
;; a full path ;; a full path
(define (combine base accum) (define (combine base accum)
(if (null? accum) (if (null? accum)
base base
(apply build-path base (reverse accum)))) (apply build-path base (reverse accum))))
(let loop ([l (if (path? (car l)) (cdr l) l)] (let loop ([l (if (path? (car l)) (cdr l) l)]
[base (if (path? (car l)) [base (if (path? (car l))
;; convert starting point absolute as needed ;; convert starting point absolute as needed
(path->complete-path (car l) (current-directory)) (path->complete-path (car l) (current-directory))
;; original must be relative ;; original must be relative
(current-directory))] (current-directory))]
[accum '()] [accum '()]
[seen #hash()]) [seen #hash()])
(cond (cond
[(null? l) (combine base accum)] [(null? l) (combine base accum)]
[(eq? 'same (car l)) [(eq? 'same (car l))
(loop (cdr l) base accum seen)] (loop (cdr l) base accum seen)]
[(eq? 'up (car l)) [(eq? 'up (car l))
(define new-base (combine base accum)) (define new-base (combine base accum))
(define target (resolve-path new-base)) (define target (resolve-path new-base))
(define-values (from-base new-seen) (define-values (from-base new-seen)
(cond (cond
[(eq? target new-base) (values new-base seen)] [(eq? target new-base) (values new-base seen)]
[else [else
(define from-base (define from-base
(cond (cond
[(complete-path? target) target] [(complete-path? target) target]
[else [else
(define-values (base-dir name dir?) (split-path new-base)) (define-values (base-dir name dir?) (split-path new-base))
(path->complete-path target base-dir)])) (path->complete-path target base-dir)]))
(when (hash-ref seen from-base #f) (when (hash-ref seen from-base #f)
(raise (raise
(exn:fail:filesystem (exn:fail:filesystem
(string-append (symbol->string who) ": cycle detected at link" (string-append (symbol->string who) ": cycle detected at link"
"\n link path: " (path->string new-base)) "\n link path: " (path->string new-base))
(current-continuation-marks)))) (current-continuation-marks))))
(values from-base (hash-set seen from-base #t))])) (values from-base (hash-set seen from-base #t))]))
(define-values (next-base name dir?) (split-path from-base)) (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 (cond
[(not next-base) [(null? l) (reverse accum)]
;; discard ".." after a root [(eq? 'same (car l)) (loop (cdr l) accum)]
(loop (cdr l) from-base '() new-seen)] [(eq? 'up (car l))
[else (cond
(loop (cdr l) next-base '() new-seen)])] [(pair? accum)
[else (loop (cdr l) base (cons (car l) accum) seen)]))] (loop (cdr l) (cdr accum))]
[else [else
;; Don't use the filesystem, so just remove (cons 'up (loop (cdr l) null))])]
;; "." and ".." syntactically [else (loop (cdr l) (cons (car l) accum))])))
(define simpler-l (apply build-path/convention-type convention (if (null? simpler-l) '(same) simpler-l))]))
(let loop ([l l] [accum null]) (define simpler-p (if (eq? convention 'windows)
(cond (simplify-backslash-backslash-questionmark simple-p)
[(null? l) (reverse accum)] simple-p))
[(eq? 'same (car l)) (loop (cdr l) accum)] (if (or (directory-path? p)
[(and (eq? 'up (car l)) (pair? accum)) (and (eq? convention 'windows)
(loop (cdr l) (cdr accum))] (unc-without-trailing-separator? simpler-p)))
[else (loop (cdr l) (cons (car l) accum))]))) (path->directory-path simpler-p)
(apply build-path simpler-l)])) simpler-p)])]))
(if (directory-path? p)
(path->directory-path simple-p)
simple-p)])]))
;; ---------------------------------------- ;; ----------------------------------------
@ -97,28 +112,144 @@
(define (simple? p convention) (define (simple? p convention)
(define bstr (path-bytes p)) (define bstr (path-bytes p))
(define len (bytes-length bstr)) (define len (bytes-length bstr))
(let loop ([i 0]) (define (is-a-sep? b)
(cond (if (eq? convention 'windows)
[(= i len) #t] (eqv? b (char->integer #\\))
[(is-sep? (bytes-ref bstr i) convention) (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 (cond
[(= (add1 i) len) #t] [(= i len) (not (special-element? elem-start i #t))]
[(is-sep? (bytes-ref bstr (add1 i)) convention) [else
#f] (define b (bytes-ref bstr i))
[(and (eq? (bytes-ref bstr (add1 i)) (char->integer #\.)) (cond
(or (= (+ i 2) len) [(eqv? b (char->integer #\\))
(is-sep? (bytes-ref bstr (+ i 2)) convention) (cond
(and (eq? (bytes-ref bstr (+ i 2)) (char->integer #\.)) [(special-element? elem-start i #f) #f]
(or (= (+ i 3) len) [else (loop (add1 i) (add1 i))])]
(is-sep? (bytes-ref bstr (+ i 3)) convention))))) [(or (eqv? b (char->integer #\/))
#f] (eqv? b (char->integer #\:))
[else (loop (add1 i))])] (eqv? b (char->integer #\"))
[(and (zero? i) (eqv? b (char->integer #\|))
(eq? (bytes-ref bstr 0) (char->integer #\.)) (eqv? b (char->integer #\<))
(or (= 1 len) (eqv? b (char->integer #\>)))
(is-sep? (bytes-ref bstr 1) convention) #f]
(and (eq? (bytes-ref bstr 1) (char->integer #\.)) [else (loop (add1 i) elem-start)])])))
(or (= 2 len) (case kind
(is-sep? (bytes-ref bstr 2) convention))))) [(abs)
#f] (cond
[else (loop (add1 i))]))) [(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) [(and ((bytes-length bstr) . > . 2)
(is-sep? (bytes-ref bstr 0) 'windows) (is-sep? (bytes-ref bstr 0) 'windows)
(is-sep? (bytes-ref bstr 1) '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 (cond
[//?-kind [//?-kind
(define allow-double-before //?-drive-end) (define allow-double-before //?-drive-end)
(cond (cond
[(or (eq? //?-kind 'rel) [(or (eq? //?-kind 'rel)
(eq? //?-kind 'red)) (eq? //?-kind 'red))
;; `\\?\REL\` or `\\?\RED\` path. Handle it directly as a special case ;; `\\?\REL\` or `\\?\RED\` path. Handle it directly as a special case
(split-reld bstr)] (split-reld bstr #:explode? explode?)]
[else [else
(split-after-drive p (split-after-drive p
#:drive-end (cond #:drive-end //?-orig-drive-end
[(and (//?-drive-end . < . (bytes-length bstr)) #:keep-drive-end (if (eq? //?-kind 'unc)
(eq? (bytes-ref bstr //?-drive-end) (char->integer #\\))) //?-orig-drive-end
;; Happens with \\?\c:\\, for example //?-drive-end)
(add1 //?-drive-end)] #:allow-double-before //?-orig-drive-end
[else //?-drive-end])
#:no-slash-sep? #t #:no-slash-sep? #t
#:no-up? #t #:no-up? #t
#:explode? explode?)])] #:explode? explode?)])]
[else [else
(define //-drive-end (parse-//-drive bstr)) (define //-drive-end (parse-//-drive bstr))
(cond (cond
[//-drive-end [//-drive-end
(split-after-drive p (split-after-drive p
#:drive-end (cond #:drive-end (cond
[(and (//-drive-end . < . (bytes-length bstr)) [(and (//-drive-end . < . (bytes-length bstr))
(is-sep? (bytes-ref bstr //?-drive-end) 'windows)) (is-sep? (bytes-ref bstr //-drive-end) 'windows))
(add1 //-drive-end)] (add1 //-drive-end)]
[else //-drive-end]) [else //-drive-end])
#:allow-double-before 1 #:allow-double-before 1
#:explode? explode?)] #:explode? explode?)]
[else [else
(split-after-drive p #:explode? explode?)])])] (split-after-drive p #:explode? explode?)])])]
[(and ((bytes-length bstr) . > . 2) [(and ((bytes-length bstr) . > . 2)
(drive-letter? (bytes-ref bstr 0)) (drive-letter? (bytes-ref bstr 0))
(eq? (bytes-ref bstr 1) (char->integer #\:))) (eq? (bytes-ref bstr 1) (char->integer #\:)))
@ -85,6 +84,7 @@
(define (split-after-drive p (define (split-after-drive p
#:len [in-len #f] #:len [in-len #f]
#:drive-end [drive-end 0] #:drive-end [drive-end 0]
#:keep-drive-end [keep-drive-end drive-end]
#:no-slash-sep? [no-slash-sep? #f] #:no-slash-sep? [no-slash-sep? #f]
#:no-up? [no-up? #f] #:no-up? [no-up? #f]
#:allow-double-before [allow-double-before 0] #:allow-double-before [allow-double-before 0]
@ -101,21 +101,25 @@
(define-values (split-pos ends-sep?) (define-values (split-pos ends-sep?)
(let loop ([i (sub1 len)] [ends-sep? #f]) (let loop ([i (sub1 len)] [ends-sep? #f])
(cond (cond
[(i . < . drive-end) (values #f ends-sep?)] [(i . < . drive-end)
[else (if (and (positive? i)
(define sep? (i . < . (sub1 len)))
(cond (values i ends-sep?)
[no-slash-sep? (eq? (bytes-ref bstr i) #\\)] (values #f ends-sep?))]
[else (is-sep? (bytes-ref bstr i) convention)])) [else
(cond (define sep?
[sep? (cond
(if (i . < . (sub1 len)) [no-slash-sep? (eq? (bytes-ref bstr i) (char->integer #\\))]
(values i ends-sep?) [else (is-sep? (bytes-ref bstr i) convention)]))
(loop (sub1 i) #t))] (cond
[else [sep?
(loop (sub1 i) ends-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)` ;; The `split-pos` argument is #f or less than `(sub1 len)`
(cond (cond
[(not split-pos) [(not split-pos)
;; No splitting available: relative or exactly a root ;; No splitting available: relative or exactly a root
@ -153,12 +157,16 @@
[else [else
(values base name is-dir?)])] (values base name is-dir?)])]
[else [else
;; Is it possible that by removing the last path element, we'll leave ;; Is it possible that by removing the last path element, we'll
;; a directory path that needs conversion to \\?\ on Windows? I think ;; leave a directory path that needs conversion to \\?\ on
;; not, because even if the remaining path ends in spaces and "."s, the ;; Windows? No: even if the remaining path ends in spaces and
;; path separator will stay in place to make the trailing spaces and ;; "."s, the path separator will stay in place to make the
;; "."s significant. ;; trailing spaces and "."s significant.
(define-values (exposed-bstr exposed-len) (values bstr (add1 split-pos))) (define-values (exposed-bstr exposed-len) (values bstr
(let ([len (add1 split-pos)])
(if (= len drive-end)
keep-drive-end
len))))
(cond (cond
[explode? [explode?
(cons name (cons name
@ -166,6 +174,7 @@
#:explode? #t #:explode? #t
#:len exposed-len #:len exposed-len
#:drive-end drive-end #:drive-end drive-end
#:keep-drive-end keep-drive-end
#:no-slash-sep? no-slash-sep? #:no-slash-sep? no-slash-sep?
#:no-up? no-up? #:no-up? no-up?
#:allow-double-before allow-double-before))] #:allow-double-before allow-double-before))]
@ -218,73 +227,86 @@
(define (parse-//?-drive bstr) (define (parse-//?-drive bstr)
(define-values (kind drive-len orig-drive-len clean-start-pos add-sep-pos) (define-values (kind drive-len orig-drive-len clean-start-pos add-sep-pos)
(parse-backslash-backslash-questionmark bstr)) (parse-backslash-backslash-questionmark bstr))
(values kind drive-len)) (values kind drive-len orig-drive-len))
(define (parse-//-drive bstr) (define (parse-//-drive bstr)
(parse-unc bstr 0)) (parse-unc bstr 0))
;; Splits a \\?\REL or \\?\RED path ;; Splits a \\?\REL or \\?\RED path
(define (split-reld bstr) (define (split-reld bstr #:explode? explode?)
(define-values (len is-dir?) (let explode-loop ([bstr bstr])
(let ([len (bytes-length bstr)]) (define-values (len is-dir?)
(cond (let ([len (bytes-length bstr)])
[(eqv? (bytes-ref bstr (sub1 len)) (char->integer #\\)) (cond
(values (sub1 len) #t)] [(eqv? (bytes-ref bstr (sub1 len)) (char->integer #\\))
[else (values (sub1 len) #t)]
(values len #f)]))) [else
(define-values (dots-end literal-start) (values len #f)])))
(backslash-backslash-questionmark-dot-ups-end bstr len)) (define-values (dots-end literal-start)
(cond (backslash-backslash-questionmark-dot-ups-end bstr len))
[(literal-start . < . len) (cond
;; There's at least one literal path [(literal-start . < . len)
(let loop ([p (sub1 len)]) ;; There's at least one literal path
(cond (let loop ([p (sub1 len)])
[(p . <= . (if dots-end (sub1 literal-start) literal-start)) (cond
;; One one element and no dots [(p . < . (if dots-end (sub1 literal-start) literal-start))
(cond ;; One one element and no dots
[(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
(cond (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)) [(eqv? (bytes-ref bstr 6) (char->integer #\L))
;; preserve separator ;; keep \\?\REL\ on path, and report 'relative as base */
1] (define elem (path (if is-dir? (subbytes bstr 0 len) bstr) 'windows))
;; preserve one separator, but not two (cond
[(eqv? (bytes-ref bstr (sub1 p)) (char->integer #\\)) [explode? (list elem)]
0] [else (values 'relative
[else 1])) elem
(values (path (subbytes bstr 0 (+ p nsep)) 'windows) is-dir?)])]
(path elem-bstr 'windows) [else
is-dir?)] ;; Switch "D" to "L", and simplify base to just "\\"
[else (loop (sub1 p))]))] (define base (path #"\\" 'windows))
[else (define elem (path
;; There are no literals --- just dots (bytes-append #"\\\\?\\REL\\"
(cond (if (eqv? (bytes-ref bstr 8) (char->integer #\\))
[((- dots-end 3) . > . 8) #""
(values (path (subbytes bstr 0 (- dots-end 3)) 'windows) #"\\")
'up (subbytes bstr 8))
#t)] 'windows))
[else (cond
(values 'relative 'up #t)])])) [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 parse-unc
backslash-backslash-questionmark-dot-ups-end backslash-backslash-questionmark-dot-ups-end
split-drive split-drive
strip-trailing-spaces) strip-trailing-spaces
strip-backslash-backslash-rel)
(define special-filenames (define special-filenames
;; and "CLOCK$" on NT --- but not traditionally detected by Racket ;; 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 2) (char->integer #\?))
(eqv? (bytes-ref bstr 3) (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 (backslash-backslash-questionmark-kind bstr)
(define-values (kind drive-end-pos orig-drive-end-pos clean-start-pos add-sep-pos) (define-values (kind drive-end-pos orig-drive-end-pos clean-start-pos add-sep-pos)
(parse-backslash-backslash-questionmark bstr)) (parse-backslash-backslash-questionmark bstr))
@ -94,7 +95,8 @@
;; ;;
;; The `orig-drive-len` result is almost the same as `drive-len`, ;; The `orig-drive-len` result is almost the same as `drive-len`,
;; but maybe longer. It preserves an artifact of the given specification: ;; 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 ;; 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 ;; removing extra slashes. It's usually the same as `drive-len`. In
@ -156,18 +158,19 @@
(loop i))]))) (loop i))])))
=> (lambda (i) => (lambda (i)
(define i+1 (add1 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 ;; Check for drive-letter case
[(and (len . > . 6) [(and (len . > . 6)
(drive-letter? (bytes-ref bstr base)) (drive-letter? (bytes-ref bstr base))
(eqv? (bytes-ref bstr (add1 base)) (char->integer #\:)) (eqv? (bytes-ref bstr (add1 base)) (char->integer #\:))
(len . > . (+ 2 base)) (len . > . (+ 2 base))
(eqv? (bytes-ref bstr (+ 2 base)) (char->integer #\\))) (eqv? (bytes-ref bstr (+ 2 base)) (char->integer #\\)))
(define drive-len (if (and (len . > . (+ 3 base)) (define drive-len (+ base 3))
(eqv? (bytes-ref bstr (+ 3 base)) (char->integer #\\))) (define orig-drive-len (if (and (len . > . drive-len)
(+ base 4) (eqv? (bytes-ref bstr drive-len) (char->integer #\\)))
(+ base 3))) (add1 drive-len)
(values 'abs drive-len drive-len (+ base 2) #"")] drive-len))
(values 'abs drive-len orig-drive-len (+ base 2) #"")]
;; Check for UNC ;; Check for UNC
[(and (len . > . (+ base 3)) [(and (len . > . (+ base 3))
(let ([b (bytes-ref bstr base)]) (let ([b (bytes-ref bstr base)])
@ -188,7 +191,7 @@
(eqv? (bytes-ref bstr drive-len) (char->integer #\\))) (eqv? (bytes-ref bstr drive-len) (char->integer #\\)))
(add1 drive-len) (add1 drive-len)
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 ;; Check for REL and RED
[(and (= base 4) [(and (= base 4)
(len . > . 8) (len . > . 8)
@ -209,6 +212,14 @@
#f)] #f)]
;; Otherwise, \\?\ is the (non-existent) drive ;; Otherwise, \\?\ is the (non-existent) drive
[else [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 (define clean-start-pos
(if (or (and (= len 5) (if (or (and (= len 5)
(eqv? (bytes-ref bstr 4) (char->integer #\\))) (eqv? (bytes-ref bstr 4) (char->integer #\\)))
@ -216,8 +227,8 @@
(eqv? (bytes-ref bstr 4) (char->integer #\\)) (eqv? (bytes-ref bstr 4) (char->integer #\\))
(eqv? (bytes-ref bstr 5) (char->integer #\\)))) (eqv? (bytes-ref bstr 5) (char->integer #\\))))
3 3
4)) orig-drive-len))
(values 'abs 4 4 clean-start-pos #"\\\\")])])) (values 'abs 4 orig-drive-len clean-start-pos #"\\\\")])]))
;; Returns an integer if this path is a UNC path, #f otherwise. ;; Returns an integer if this path is a UNC path, #f otherwise.
;; If `delta` is non-0, then `delta` is after a leading \\. ;; If `delta` is non-0, then `delta` is after a leading \\.
@ -286,6 +297,11 @@
;; We have //?/, with up to 2 backslashes. ;; We have //?/, with up to 2 backslashes.
;; This doesn't count as UNC, to avoid confusion with \\?\. ;; This doesn't count as UNC, to avoid confusion with \\?\.
#f] #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 [else
(let loop ([j j]) (let loop ([j j])
(cond (cond
@ -356,7 +372,6 @@
[else [else
(values #f 8)])) (values #f 8)]))
(define (split-drive bstr) (define (split-drive bstr)
(cond (cond
[(backslash-backslash-questionmark? bstr) [(backslash-backslash-questionmark? bstr)
@ -382,7 +397,9 @@
(define i (sub1 i+1)) (define i (sub1 i+1))
(cond (cond
[(is-sep? (bytes-ref bstr i) 'windows) [(is-sep? (bytes-ref bstr i) 'windows)
(loop i)] (if (zero? i)
0
(loop i))]
[else i+1]))) [else i+1])))
(let loop ([i+1 len-before-seps]) (let loop ([i+1 len-before-seps])
(cond (cond
@ -406,3 +423,12 @@
;; Trim ;; Trim
(bytes-append (subbytes bstr 0 i+1) (bytes-append (subbytes bstr 0 i+1)
(subbytes bstr len-before-seps len))])]))])) (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, Scheme_Object *make_exposed_sized_offset_path(int *optional, int already_protected,
char *chars, intptr_t d, intptr_t len, int copy, char *chars, intptr_t d, intptr_t len, int copy,
int kind) int kind)
/* Called to make a directory path where the end has been removed. /* 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 "\\?\". */
{ {
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 /* We may need to remove a redundant separator from the directory
path. Try removing it, and see if anyone would care: */ path. Try removing it, and see if anyone would care: */
if (do_path_to_directory_path(chars, d, len - 1, scheme_true, 1, kind)) { 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 else
len = strlen(s); 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])) { if ((len - skip_end > delta) && IS_A_DOS_SEP(s[len - 1 - skip_end])) {
skip_end++; return (char *)s;
} }
if ((len - skip_end > delta) if ((len - skip_end > delta)

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

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