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

fixed processing of file: URLs to not assume Unix conventions and to distinguish relative and absolute paths

Browse Source 
svn: r1463

original commit: b41c9de014530a5914a814b4f885ad0a2ba965fb
This commit is contained in:
Matthew Flatt 2005-12-01 20:07:04 +00:00
parent 6ef89da68b
commit 4d999e7962
1 changed files with 30 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/net/url-unit.ss
View File

@ -61,6 +61,11 @@
args))))) args)))))
(raise (make-url-exception s (current-continuation-marks)))))) (raise (make-url-exception s (current-continuation-marks))))))
(define (url->file-path url)
(path->string
(apply build-path (or (url-host url) 'same)
(map (lambda (x) (if (equal? x "") 'same x)) (url-path url)))))
(define url->string (define url->string
(lambda (url) (lambda (url)
(let ((scheme (url-scheme url)) (let ((scheme (url-scheme url))
@ -72,7 +77,8 @@
(fragment (url-fragment url))) (fragment (url-fragment url)))
(cond (cond
((and scheme (string=? scheme "file")) ((and scheme (string=? scheme "file"))
(string-append "file:" (combine-path-strings path) (string-append "file:"
(url->file-path url)
(or (and (not fragment) "") (or (and (not fragment) "")
(string-append "#" fragment)))) (string-append "#" fragment))))
(else (else
@ -142,9 +148,7 @@
;; file://get-pure-port : url -> in-port ;; file://get-pure-port : url -> in-port
(define file://get-pure-port (define file://get-pure-port
(lambda (url) (lambda (url)
(when (url-host url) (open-input-file (url->file-path url))))
(url-error "Don't know how to get files from remote hosts"))
(open-input-file (apply build-path (url-path url)))))
(define (schemeless-url url) (define (schemeless-url url)
(url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url)) (url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url))
@ -343,13 +347,28 @@
[fragment (caddr path+fragment)]) [fragment (caddr path+fragment)])
(if (or (relative-path? path) (if (or (relative-path? path)
(absolute-path? path)) (absolute-path? path))
(make-url "file" (let-values ([(root elems kind)
#f ; user (let loop ([path (simplify-path path)][accum null][kind #f])
#f ; host (let-values ([(base name dir?) (split-path path)])
#f ; port (let ([kind (or kind
(separate-path-strings path) (if dir? 'dir 'file))])
'() ; query (cond
fragment) [(path? base)
(loop base (cons name accum) kind)]
[(eq? base 'relative)
(values #f (cons name accum) kind)]
[else
(values path accum kind)]))))])
(make-url "file"
#f ; user
(and root (path->string root)) ; host
#f ; port
(append (map path->string elems)
(if (eq? kind 'dir)
'("")
null))
'() ; query
fragment))
(url-error "scheme 'file' path ~s neither relative nor absolute" path)))) (url-error "scheme 'file' path ~s neither relative nor absolute" path))))
;; Other scheme: ;; Other scheme:
(let ((match (regexp-match-positions rx str))) (let ((match (regexp-match-positions rx str)))