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

fix reference for file:// urls (see PR8060)

Browse Source 
svn: r3098
This commit is contained in:
Eli Barzilay 2006-05-28 22:35:16 +00:00
parent 8593839057
commit f9c7a1dd6e
1 changed files with 28 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -14,6 +14,7 @@
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "port.ss") (lib "port.ss")
(lib "string.ss") (lib "string.ss")
(lib "list.ss")
"url-structs.ss" "url-structs.ss"
"uri-codec.ss" "uri-codec.ss"
"url-sig.ss" "url-sig.ss"
@ -140,14 +141,32 @@
(tcp-abandon-port client->server) ; flushes (tcp-abandon-port client->server) ; flushes
server->client))) server->client)))
(define (file://->path url)
;; remove all ""s
(let ([elts (remove* '("") (map path/param-path (url-path url)))]
[abs? (url-path-absolute? url)])
;; See the discussion in PR8060 for an explanation
(if (eq? 'windows (system-type))
(let ([host (or (url-host url) "")])
(when (and (not abs?) host (pair? elts) (equal? ":" (car elts)))
(set-car! elts (string-append host ":"))
(set! host ""))
(unless (equal? "" host) (set! elts (cons host elts)))
(if (null? elts)
(build-path) ; make it throw the error
(let* ([fst (car elts)] [len (string-length fst)])
(if (or (not abs?) (eq? #\: (string-ref fst (sub1 len))))
(apply build-path elts)
(if (null? (cdr elts))
(build-path (string-append "\\\\" (car elts)))
(apply build-path
(string-append "\\\\" (car elts) "\\" (cadr elts))
(cddr elts)))))))
(apply build-path (if abs? (cons "/" elts) elts)))))
;; file://get-pure-port : url -> in-port ;; file://get-pure-port : url -> in-port
(define (file://get-pure-port url) (define (file://get-pure-port url)
(open-input-file (open-input-file (file://->path url)))
(apply
build-path
(map
path/param-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))