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

fixed up file: urls and fixed a bug in the parsing of urls with empty string host names

Browse Source 
svn: r1779
This commit is contained in:
Robby Findler 2006-01-07 03:25:26 +00:00
parent 00dece4975
commit aa5d3f7378
3 changed files with 95 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/help/private/gui.ss
View File

@ -8,6 +8,7 @@
(lib "etc.ss")
(lib "unitsig.ss")
(lib "list.ss")
(lib "file.ss")
(lib "string-constant.ss" "string-constants")
(lib "external.ss" "browser")
@ -15,6 +16,7 @@
(lib "browser-sig.ss" "browser")
(lib "url-sig.ss" "net")
(lib "url-structs.ss" "net")
(lib "uri-codec.ss" "net")
"sig.ss"
"../bug-report.ss"
(lib "bday.ss" "framework" "private")
@ -137,7 +139,7 @@
;; send the url off to another browser
[(or (and (string? (url-scheme url))
(not (equal? (url-scheme url) "http")))
(not (member (url-scheme url) '("http"))))
(and (preferences:get 'drscheme:help-desk:ask-about-external-urls)
(ask-user-about-separate-browser))
(preferences:get 'drscheme:help-desk:separate-browser))
@ -556,8 +558,17 @@
(lambda (b e)
(let ([f (get-file)])
(when f
(send t set-value (string-append "file:" (path->string f)))
(send t set-value (encode-file-path-as-url f))
(update-ok))))))
(define (encode-file-path-as-url f)
(apply
string-append
"file:"
(map
(λ (x) (string-append "/" (uri-path-segment-encode (path->string x))))
(explode-path f))))
(define spacer (make-object vertical-pane% p))
(define result #f)
(define (ok-callback b e)

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

@ -62,13 +62,6 @@
args)))))
(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))
(map path/param-path
(url-path url))))))
(define url->string
(lambda (url)
(let ((scheme (url-scheme url))
@ -78,13 +71,6 @@
(path (url-path url))
(query (url-query url))
(fragment (url-fragment url)))
(cond
((and scheme (string=? scheme "file"))
(string-append "file:"
(url->file-path url)
(or (and (not fragment) "")
(string-append "#" fragment))))
(else
(let ((sa string-append))
(sa (if scheme (sa scheme ":") "")
(if (or user host port)
@ -100,7 +86,7 @@
(combine-path-strings (url-path-absolute? url) path)
;(if query (sa "?" (uri-encode query)) "")
(if (null? query) "" (sa "?" (alist->form-urlencoded query)))
(if fragment (sa "#" (uri-encode fragment)) ""))))))))
(if fragment (sa "#" (uri-encode fragment)) ""))))))
;; url->default-port : url -> num
(define url->default-port
@ -155,9 +141,13 @@
server->client)))
;; file://get-pure-port : url -> in-port
(define file://get-pure-port
(lambda (url)
(open-input-file (url->file-path url))))
(define (file://get-pure-port url)
(open-input-file
(apply
build-path
(map
path/param-path
(url-path url)))))
(define (schemeless-url url)
(url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url))
@ -371,7 +361,7 @@
"(" ; <3 slashslash-opt
"//"
"([^:/@;?#]*@)?" ; =4 user-at-opt
"([^:/@;?#]+)?" ; =5 host-opt
"([^:/@;?#]*)?" ; =5 host-opt
"(:[0-9]*)?" ; =6 colon-port-opt
")?" ; >3 slashslash-opt
")?" ; >1 front-opt
@ -381,39 +371,6 @@
"[ \t\f\r\n]*"
"$"))))
(lambda (str)
(let ([m (regexp-match #rx"^[ \t\f\r\n]*file:(.*)$" str)])
;; File scheme:
(if m
(let ([path+fragment (regexp-match #rx"^([^#]*)(#(.*))?$" (cadr m))])
(let ([path (cadr path+fragment)]
[fragment (caddr path+fragment)])
(if (or (relative-path? path)
(absolute-path? path))
(let-values ([(root elems kind)
(let loop ([path (simplify-path path)][accum null][kind #f])
(let-values ([(base name dir?) (split-path path)])
(let ([kind (or kind
(if dir? 'dir 'file))])
(cond
[(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
(absolute-path? path)
(append (map (λ (x) (make-path/param (path->string x) '())) elems)
(if (eq? kind 'dir)
(list (make-path/param "" '()))
null))
'() ; query
fragment))
(url-error "scheme 'file' path ~s neither relative nor absolute" path))))
;; Other scheme:
(let ((match (regexp-match-positions rx str)))
(if match
(let* ((get-str (lambda (pos skip-left skip-right)
@ -453,7 +410,7 @@
(if q (form-urlencoded->alist q) '()))
(uri-decode/maybe (get-str 9 1 0)) ; fragment
))
(url-error "Invalid URL string: ~e" str))))))))
(url-error "Invalid URL string: ~e" str))))))
(define (uri-decode/maybe f)
;; If #f, and leave unmolested any % that is followed by hex digit

13
collects/tests/mzscheme/net.ss
View File

@ -180,6 +180,12 @@
"/")
(test-s->u (vector #f #f #f #f #f '() '() #f)
"")
(test-s->u (vector "http" #f #f #f #t '(#("")) '() #f)
"http:/")
(test-s->u (vector "http" #f "" #f #t '(#("")) '() #f)
"http:///")
(test-s->u (vector "http" #f "www.drscheme.org" #f #f '() '() #f)
"http://www.drscheme.org")
(test-s->u (vector "http" #f "www.drscheme.org" #f #t '(#("")) '() #f)
@ -234,7 +240,14 @@
(test-s->u (vector "http" #f "www.drscheme.org" #f #t (list #("." "") #(".." "") #(same "") #(up "") #("..." "") #("abc.def" "")) '() #f)
"http://www.drscheme.org/%2e;/%2e%2e;/.;/..;/...;/abc.def;")
;; test file: urls
(test-s->u (vector "file" #f #f #f #t '(#("abc") #("def.html")) '() #f)
"file:/abc/def.html")
(test-s->u (vector "file" #f "localhost" #f #t '(#("abc") #("def.html")) '() #f)
"file://localhost/abc/def.html")
;; test case sensitivity
(test (vector "http" "ROBBY" "www.drscheme.org" 80 #t '(#("INDEX.HTML" "XXX")) '((T . "P")) "YYY")
string->url/vec
"HTTP://ROBBY@WWW.DRSCHEME.ORG:80/INDEX.HTML;XXX?T=P#YYY")