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

.

Browse Source 
original commit: 3dfd85e6479ef58e2568fa84c5b13fc8d6cb8f12
This commit is contained in:
Matthew Flatt 2003-04-06 00:11:38 +00:00
parent f4d8112d90
commit 13a88eac98
2 changed files with 79 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/net/url-sig.ss
View File

@ -4,6 +4,7 @@
(define-signature net:url^
((struct url (scheme host port path params query fragment))
(struct url/user (user)) ; sub-struct of url
get-pure-port ;; url [x list (str)] -> in-port
get-impure-port ;; url [x list (str)] -> in-port
post-pure-port ;; url [x list (str)] -> in-port

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

@ -80,6 +80,7 @@
;; query : str + #f
;; fragment : str + #f
(define-struct url (scheme host port path params query fragment))
(define-struct (url/user url) (user))
(define url->string
(lambda (url)
@ -422,19 +423,6 @@
(define character-set-size 256)
(define marker-list
'(#\: #\; #\? #\#))
(define ascii-marker-list
(map char->integer marker-list))
(define marker-locations
(make-vector character-set-size))
(define first-position-of-marker
(lambda (c)
(vector-ref marker-locations (char->integer c))))
;; netscape/string->url : str -> url
(define netscape/string->url
(lambda (string)
@ -451,8 +439,84 @@
url))))))
;; string->url : str -> url
;; New implemenation, mostly provided by Neil Van Dyke
(define string->url
(let ((rx (regexp (string-append
"^"
"[ \t\f\r\n]*"
"(" ; <1 front-opt
"([a-zA-Z]*:)?" ; =2 scheme-colon-opt
"(" ; <3 slashslash-opt
"//"
"([^:/@;?#]*@)?" ; =4 user-at-opt
"([^:/@;?#]+)?" ; =5 host-opt
"(:[0-9]*)?" ; =6 colon-port-opt
")?" ; >3 slashslash-opt
")?" ; >1 front-opt
"([^;?#]*)" ; =7 path
"(;[^?#]*)?" ; =8 semi-parms-opt
"(\\?[^#]*)?" ; =9 question-query-opt
"(#.*)?" ; =10 hash-fragment-opt
"[ \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))
(make-url "file"
#f ; host
#f ; port
path
#f ; params
#f ; 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)
(let ((pair (list-ref match pos)))
(if pair
(substring str
(+ (car pair) skip-left)
(- (cdr pair) skip-right))
#f))))
(get-num (lambda (pos skip-left skip-right)
(let ((s (get-str pos skip-left skip-right)))
(if s (string->number s) #f)))))
(make-url/user (get-str 2 0 1) ; scheme
(get-str 5 0 0) ; host
(get-num 6 1 0) ; port
(get-str 7 0 0) ; path
(get-str 8 1 0) ; params
(get-str 9 1 0) ; query
(get-str 10 1 0) ; fragment
(get-str 4 0 1) ; user
))
(url-error "Invalid URL string: ~e" str))))))))
#|
Old version. See PR 6152 for information on its replacement.
(define string->url
(lambda (string)
(define marker-list
'(#\: #\; #\? #\#))
(define ascii-marker-list
(map char->integer marker-list))
(define marker-locations
(make-vector character-set-size))
(define first-position-of-marker
(lambda (c)
(vector-ref marker-locations (char->integer c))))
(with-handlers [(exn? (lambda (exn)
(url-error "Invalid URL string: ~s" string)))]
(let loop ((markers ascii-marker-list))
@ -528,6 +592,7 @@
(and fragment-start
(substring string fragment-start
fragment-finish)))))))))))))
|#
;; parse-host/port/path : str x num x num -> (str + #f) + (num + #f) + str
(define parse-host/port/path