diff --git a/pkgs/racket-doc/scribblings/reference/paths.scrbl b/pkgs/racket-doc/scribblings/reference/paths.scrbl index 2a38872946..8ad58ae717 100644 --- a/pkgs/racket-doc/scribblings/reference/paths.scrbl +++ b/pkgs/racket-doc/scribblings/reference/paths.scrbl @@ -374,7 +374,7 @@ same file or directory as @racket[path]. If @racket[path] is a soft link to another path, then the referenced path is returned (this may be a relative path with respect to the directory owning @racket[path]), otherwise @racket[path] is returned (after -expansion). +cleansing). On Windows, the path for a link should be simplified syntactically, so that an up-directory indicator removes a preceding path element diff --git a/pkgs/racket-test-core/tests/racket/path.rktl b/pkgs/racket-test-core/tests/racket/path.rktl index 0ba7cd21b6..1cc60ffd8a 100644 --- a/pkgs/racket-test-core/tests/racket/path.rktl +++ b/pkgs/racket-test-core/tests/racket/path.rktl @@ -482,6 +482,22 @@ ; normal-case-path now checks for pathness: (err/rt-test (normal-case-path (string #\a #\nul #\b))) +;; Check that `cleanse-path` and `resolve-path` keep relative paths +;; and keep forward slashes on Windows +(let () + (define (check-cleanse cleanse-path) + (test (build-path "not-there" "file-also-not-there") + cleanse-path + (build-path "not-there" "file-also-not-there")) + (test (string->path "not-there/b") cleanse-path "not-there///b") + (when (eq? 'windows (system-path-convention-type)) + (test (string->path "not-there\\b") cleanse-path "not-there\\\\b") + (test (string->path "not-there\\b/c") cleanse-path "not-there\\\\b/c") + (test (string->path "not-there\\b/c") cleanse-path "not-there\\b//c") + (test (string->path "not-there\\b/c") cleanse-path "not-there\\\\b//c"))) + (check-cleanse cleanse-path) + (check-cleanse resolve-path)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; \\?\ paths in Windows diff --git a/racket/src/io/file/host.rkt b/racket/src/io/file/host.rkt index ca525195ce..da769968d5 100644 --- a/racket/src/io/file/host.rkt +++ b/racket/src/io/file/host.rkt @@ -18,7 +18,7 @@ (let ([p (->path p)]) (when who (security-guard-check-file who p guards)) - (path-bytes (cleanse-path (path->complete-path p current-directory #:wrt-given? #f))))) + (path-bytes (cleanse-path/convert-slashes (path->complete-path p current-directory #:wrt-given? #f))))) (define (->host/as-is p who src) (let ([p (->path p)]) diff --git a/racket/src/io/file/main.rkt b/racket/src/io/file/main.rkt index 0802fb1f6b..b630910a7a 100644 --- a/racket/src/io/file/main.rkt +++ b/racket/src/io/file/main.rkt @@ -4,6 +4,7 @@ "../path/path.rkt" "../path/parameter.rkt" "../path/directory-path.rkt" + "../path/cleanse.rkt" (only-in "../path/windows.rkt" special-filename?) "../host/rktio.rkt" "../host/thread.rkt" @@ -375,7 +376,8 @@ (define (do-resolve-path p who) (check who path-string? p) - (define host-path (->host p who '(exists))) + (define p-path (->path p)) + (define host-path (->host p-path who '(exists))) (define host-path/no-sep (host-path->host-path-without-trailing-separator host-path)) (start-atomic) (define r0 (rktio_readlink rktio host-path/no-sep)) @@ -388,10 +390,10 @@ (cond [(rktio-error? r) ;; Errors are not reported, but are treated like non-links - (define new-path (host-> host-path)) + (define new-path (cleanse-path p-path)) ;; If cleansing didn't change p, then return an `eq?` path (cond - [(equal? new-path p) p] + [(equal? new-path p-path) p-path] [else new-path])] [else (host-> r)])) diff --git a/racket/src/io/path/api.rkt b/racket/src/io/path/api.rkt index 9541056298..3b7a0d715a 100644 --- a/racket/src/io/path/api.rkt +++ b/racket/src/io/path/api.rkt @@ -11,7 +11,8 @@ "path.rkt" "relativity.rkt" "simplify.rkt" - "directory-path.rkt") + "directory-path.rkt" + (only-in "windows.rkt" split-drive)) (provide path->complete-path current-drive @@ -32,7 +33,8 @@ (security-guard-check-file who #f '(exists)) (if (eq? (system-path-convention-type) 'unix) (string->path "/") - (error who "not yet ready"))) + (let ([dir (current-directory)]) + (path (split-drive (path-bytes dir)) 'windows)))) ;; ---------------------------------------- diff --git a/racket/src/io/path/cleanse.rkt b/racket/src/io/path/cleanse.rkt index 8ad2f925f1..2aee089129 100644 --- a/racket/src/io/path/cleanse.rkt +++ b/racket/src/io/path/cleanse.rkt @@ -7,11 +7,17 @@ "windows.rkt") (provide cleanse-path + cleanse-path/convert-slashes clean-double-slashes) (define/who (cleanse-path p-in) (check-path-argument who p-in) - (define p (->path p-in)) + (do-cleanse-path (->path p-in) #f)) + +(define (cleanse-path/convert-slashes p) + (do-cleanse-path p #t)) + +(define (do-cleanse-path p convert-slashes?) (define convention (path-convention p)) (define (return bstr) (if (eq? bstr (path-bytes p)) @@ -49,21 +55,21 @@ [(parse-unc bstr 0) => (lambda (drive-len) (return (clean-double-slashes bstr 'windows (sub1 drive-len) - #:to-backslash-from 0)))] + #:to-backslash-from (and convert-slashes? 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 - #:to-backslash-from 2))] + #:to-backslash-from (and convert-slashes? 2)))] [else (return (bytes-append (subbytes bstr 0 2) #"\\" (clean-double-slashes (subbytes bstr 2) 'windows 0 - #:to-backslash-from 0)))])] + #:to-backslash-from (and convert-slashes? 0))))])] [else (return (clean-double-slashes bstr 'windows 0 - #:to-backslash-from 0))])])) + #:to-backslash-from (and convert-slashes? 0)))])])) ;; ---------------------------------------- diff --git a/racket/src/io/path/simplify.rkt b/racket/src/io/path/simplify.rkt index e3eeb20ffe..aebd95a3f8 100644 --- a/racket/src/io/path/simplify.rkt +++ b/racket/src/io/path/simplify.rkt @@ -28,7 +28,7 @@ (cond [(simple? p convention) p] [else - (define clean-p (cleanse-path p)) + (define clean-p (cleanse-path/convert-slashes p)) (cond [(simple? clean-p convention) clean-p] [else