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

path->url: ensure directory paths have a trailing slash

Browse Source 
If a path to a directory is converted to an URL it loses
           its trailing path separator.
           This can lead to a bug if the URL is used as a base URL to
           build other URLs (e.g. combine-url/relative).
This commit is contained in:
Philippe Mechai 2012-11-06 22:59:12 +01:00 committed by Matthew Flatt
parent 36bfae9497
commit d8ff661118
1 changed files with 47 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/net/url.rkt
View File

@ -558,47 +558,53 @@
";")) ";"))
(define (path->url path) (define (path->url path)
(let ([url-path (let* ([spath (simplify-path path #f)]
(let loop ([path (simplify-path path #f)][accum null]) [dir? (let-values ([(b n dir?) (split-path spath)]) dir?)]
(let-values ([(base name dir?) (split-path path)]) ;; If original path is a directory the resulting URL
(cond ;; should have a trailing forward slash
[(not base) [url-tail (if dir? (list (make-path/param "" null)) null)]
(append (map [url-path
(lambda (s) (let loop ([path spath][accum null])
(make-path/param s null)) (let-values ([(base name dir?) (split-path path)])
(if (eq? (path-convention-type path) 'windows) (cond
;; For Windows, massage the root: [(not base)
(let ([s (regexp-replace (append (map
#rx"[/\\\\]$" (lambda (s)
(bytes->string/utf-8 (path->bytes name)) (make-path/param s null))
"")]) (if (eq? (path-convention-type path) 'windows)
(cond ;; For Windows, massage the root:
[(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s) (let ([s (regexp-replace
;; \\?\<drive>: path: #rx"[/\\\\]$"
(regexp-split #rx"[/\\]+" (substring s 4))] (bytes->string/utf-8 (path->bytes name))
[(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s) "")])
;; \\?\ UNC path: (cond
(regexp-split #rx"[/\\]+" (substring s 7))] [(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s)
[(regexp-match? #rx"^[/\\]" s) ;; \\?\<drive>: path:
;; UNC path: (regexp-split #rx"[/\\]+" (substring s 4))]
(regexp-split #rx"[/\\]+" s)] [(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s)
[else ;; \\?\ UNC path:
(list s)])) (regexp-split #rx"[/\\]+" (substring s 7))]
;; On other platforms, we drop the root: [(regexp-match? #rx"^[/\\]" s)
null)) ;; UNC path:
accum)] (regexp-split #rx"[/\\]+" s)]
[else [else
(let ([accum (cons (make-path/param (list s)]))
(if (symbol? name) ;; On other platforms, we drop the root:
name null))
(bytes->string/utf-8 accum)]
(path-element->bytes name))) [else
null) (let ([accum (cons (make-path/param
accum)]) (if (symbol? name)
(if (eq? base 'relative) name
accum (bytes->string/utf-8
(loop base accum)))])))]) (path-element->bytes name)))
(make-url "file" #f "" #f (absolute-path? path) url-path '() #f))) null)
accum)])
(if (eq? base 'relative)
accum
(loop base accum)))])))])
(make-url "file" #f "" #f (absolute-path? path) (append url-path url-tail) '() #f)))
(define (url->path url [kind (system-path-convention-type)]) (define (url->path url [kind (system-path-convention-type)])
(file://->path url kind)) (file://->path url kind))