From: Chris Hanson Date: Thu, 2 Feb 2006 01:02:12 +0000 (+0000) Subject: Change all URI procedures to accept any object that can be coerced to X-Git-Tag: 20090517-FFI~1113 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3e0aefd7cd3dccd64af89b39f42d87138f669cde;p=mit-scheme.git Change all URI procedures to accept any object that can be coerced to a URI by ->URI. --- diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 26a3123eb..899b8c891 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.572 2006/01/31 18:50:03 cph Exp $ +$Id: runtime.pkg,v 14.573 2006/02/02 01:02:07 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -4765,12 +4765,18 @@ USA. (files "url") (parent (runtime)) (export () + (guarantee-absolute-uri ->absolute-uri) + (guarantee-relative-uri ->relative-uri) + (guarantee-uri ->uri) (url:decode-string decode-component) (url:match:escape matcher:pct-encoded) (url:parse:hostport parser:hostport) ->absolute-uri ->relative-uri ->uri + + + absolute-uri? char-set:uri-alpha char-set:uri-digit @@ -4784,9 +4790,7 @@ USA. char-set:uri-segment char-set:uri-segment-nc char-set:uri-userinfo - error:not-absolute-uri error:not-partial-uri - error:not-relative-uri error:not-uri error:not-uri-authority error:not-uri-host @@ -4794,10 +4798,7 @@ USA. error:not-uri-port error:not-uri-scheme error:not-uri-userinfo - guarantee-absolute-uri guarantee-partial-uri - guarantee-relative-uri - guarantee-uri guarantee-uri-authority guarantee-uri-host guarantee-uri-path diff --git a/v7/src/runtime/url.scm b/v7/src/runtime/url.scm index 00fab9212..2cbe557c1 100644 --- a/v7/src/runtime/url.scm +++ b/v7/src/runtime/url.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: url.scm,v 1.39 2006/01/31 17:58:54 cph Exp $ +$Id: url.scm,v 1.40 2006/02/02 01:02:12 cph Exp $ Copyright 2000,2001,2003,2004,2005,2006 Massachusetts Institute of Technology @@ -32,19 +32,19 @@ USA. (define-record-type (%%make-uri scheme authority path query fragment string) - uri? - (scheme uri-scheme) - (authority uri-authority) - (path uri-path) - (query uri-query) - (fragment uri-fragment) - (string uri-string)) + %uri? + (scheme %uri-scheme) + (authority %uri-authority) + (path %uri-path) + (query %uri-query) + (fragment %uri-fragment) + (string %uri-string)) (set-record-type-unparser-method! (standard-unparser-method 'URI (lambda (uri port) (write-char #\space port) - (write (uri-string uri) port)))) + (write (uri->string uri) port)))) (define (make-uri scheme authority path query fragment) (let ((path (if (equal? path '("")) '() path))) @@ -74,23 +74,38 @@ USA. (define interned-uris) -(define (absolute-uri? object) - (and (uri? object) - (uri-absolute? object))) +(define (uri-scheme uri) + (%uri-scheme (->uri uri 'URI-SCHEME))) -(define (relative-uri? object) - (and (uri? object) - (uri-relative? object))) +(define (uri-authority uri) + (%uri-authority (->uri uri 'URI-AUTHORITY))) + +(define (uri-path uri) + (%uri-path (->uri uri 'URI-PATH))) -(define-integrable (uri-absolute? uri) +(define (uri-query uri) + (%uri-query (->uri uri 'URI-QUERY))) + +(define (uri-fragment uri) + (%uri-fragment (->uri uri 'URI-FRAGMENT))) + +(define (uri-absolute? uri) (if (uri-scheme uri) #t #f)) -(define-integrable (uri-relative? uri) +(define (uri-relative? uri) (if (uri-scheme uri) #f #t)) -(define-guarantee uri "URI") -(define-guarantee relative-uri "relative URI") -(define-guarantee absolute-uri "absolute URI") +(define (uri? object) + (%->uri object parse-uri 'URI? #f)) + +(define (absolute-uri? object) + (%->uri object parse-absolute-uri 'ABSOLUTE-URI? #f)) + +(define (relative-uri? object) + (%->uri object parse-relative-uri 'ABSOLUTE-URI? #f)) + +(define (error:not-uri object caller) + (error:wrong-type-argument object "URI" caller)) (define (uri-scheme? object) (and (interned-symbol? object) @@ -186,66 +201,67 @@ USA. (eq? a1 a2)) (define (uri->alist uri) - `(,@(if (uri-scheme uri) - `((scheme ,(uri-scheme uri))) - '()) - ,@(if (uri-authority uri) - (let ((a (uri-authority uri))) - `(,@(if (uri-authority-userinfo a) - `((userinfo ,(uri-authority-userinfo a))) - '()) - (host ,(uri-authority-host a)) - ,@(if (uri-authority-port a) - `((port ,(uri-authority-port a))) - '()))) - '()) - (path ,(uri-path uri)) - ,@(if (uri-query uri) - `((query ,(uri-query uri))) - '()) - ,@(if (uri-fragment uri) - `((fragment ,(uri-fragment uri))) - '()))) + (let ((uri (->uri uri 'URI->ALIST))) + `(,@(if (%uri-scheme uri) + `((scheme ,(%uri-scheme uri))) + '()) + ,@(if (%uri-authority uri) + (let ((a (%uri-authority uri))) + `(,@(if (uri-authority-userinfo a) + `((userinfo ,(uri-authority-userinfo a))) + '()) + (host ,(uri-authority-host a)) + ,@(if (uri-authority-port a) + `((port ,(uri-authority-port a))) + '()))) + '()) + (path ,(%uri-path uri)) + ,@(if (%uri-query uri) + `((query ,(%uri-query uri))) + '()) + ,@(if (%uri-fragment uri) + `((fragment ,(%uri-fragment uri))) + '())))) ;;;; Merging (define (merge-uris uri base-uri) - (guarantee-absolute-uri base-uri 'MERGE-URIS) - (let ((uri (->uri uri 'MERGE-URIS))) - (cond ((uri-scheme uri) - (%make-uri (uri-scheme uri) - (uri-authority uri) - (remove-dot-segments (uri-path uri)) - (uri-query uri) - (uri-fragment uri))) - ((uri-authority uri) - (%make-uri (uri-scheme base-uri) - (uri-authority uri) - (remove-dot-segments (uri-path uri)) - (uri-query uri) - (uri-fragment uri))) - ((null? (uri-path uri)) - (%make-uri (uri-scheme base-uri) - (uri-authority base-uri) - (uri-path base-uri) - (or (uri-query uri) (uri-query base-uri)) - (uri-fragment uri))) + (let ((uri (->uri uri 'MERGE-URIS)) + (base-uri (->absolute-uri base-uri 'MERGE-URIS))) + (cond ((%uri-scheme uri) + (%make-uri (%uri-scheme uri) + (%uri-authority uri) + (remove-dot-segments (%uri-path uri)) + (%uri-query uri) + (%uri-fragment uri))) + ((%uri-authority uri) + (%make-uri (%uri-scheme base-uri) + (%uri-authority uri) + (remove-dot-segments (%uri-path uri)) + (%uri-query uri) + (%uri-fragment uri))) + ((null? (%uri-path uri)) + (%make-uri (%uri-scheme base-uri) + (%uri-authority base-uri) + (%uri-path base-uri) + (or (%uri-query uri) (%uri-query base-uri)) + (%uri-fragment uri))) (else - (%make-uri (uri-scheme base-uri) - (uri-authority base-uri) + (%make-uri (%uri-scheme base-uri) + (%uri-authority base-uri) (remove-dot-segments - (merge-paths (uri-path uri) base-uri)) - (uri-query uri) - (uri-fragment uri)))))) + (merge-paths (%uri-path uri) base-uri)) + (%uri-query uri) + (%uri-fragment uri)))))) (define (merge-paths ref-path base-uri) (cond ((path-absolute? ref-path) ref-path) - ((and (uri-authority base-uri) - (null? (uri-path base-uri))) + ((and (%uri-authority base-uri) + (null? (%uri-path base-uri))) (cons "" ref-path)) (else - (let ((path (uri-path base-uri))) + (let ((path (%uri-path base-uri))) (if (and (pair? path) (pair? (cdr path))) (append (except-last-pair path) ref-path) @@ -295,36 +311,40 @@ USA. ;;;; Parser -(define-syntax define-uri-coercion - (sc-macro-transformer - (lambda (form environment) - environment - (if (syntax-match? '(SYMBOL) (cdr form)) - (let* ((root (cadr form)) - (parser (symbol 'PARSE- root))) - `(DEFINE (,(symbol '-> root) OBJECT #!OPTIONAL CALLER) - (COND ((,(symbol root '?) OBJECT) - OBJECT) - ((STRING? OBJECT) - (%STRING->URI ,parser OBJECT #!DEFAULT #!DEFAULT CALLER)) - (ELSE - (OR (COMPLETE-PARSE - ,parser - (OR (->PARSER-BUFFER OBJECT) - (,(symbol 'ERROR:NOT- root) OBJECT CALLER))) - (ERROR:BAD-RANGE-ARGUMENT OBJECT CALLER)))))) - (ill-formed-syntax form))))) - -(define-uri-coercion uri) -(define-uri-coercion absolute-uri) -(define-uri-coercion relative-uri) - -(define (->parser-buffer object) - (cond ((or (string? object) (wide-string? object)) - (string->parser-buffer object)) - ((input-port? object) (input-port->parser-buffer object)) - ((symbol? object) (string->parser-buffer (symbol->wide-string object))) - (else #f))) +(define (->uri object #!optional caller) + (%->uri object parse-uri caller #t)) + +(define (->absolute-uri object #!optional caller) + (%->uri object parse-absolute-uri caller #t)) + +(define (->relative-uri object #!optional caller) + (%->uri object parse-relative-uri caller #t)) + +(define (%->uri object parser caller error?) + ;; Kludge: take advantage of fact that (NOT (NOT #!DEFAULT)). + (let* ((do-parse + (lambda (string) + (let ((uri (complete-parse parser (string->parser-buffer string)))) + (if (and (not uri) error?) + (error:bad-range-argument object caller)) + uri))) + (do-string + (lambda (string) + (or (hash-table/get interned-uris string #f) + (do-parse (utf8-string->wide-string string)))))) + (cond ((%uri? object) + object) + ((string? object) + (do-string object)) + ((symbol? object) + (do-string (symbol-name object))) + ((wide-string? object) + (let ((string (wide-string->utf8-string object))) + (or (hash-table/get interned-uris string #f) + (do-parse object)))) + (else + (if error? (error:not-uri object caller)) + #f)))) (define (string->uri string #!optional start end) (%string->uri parse-uri string start end 'STRING->URI)) @@ -552,14 +572,13 @@ USA. ;;;; Output (define (uri->string uri) - (uri-string (->uri uri 'URI->STRING))) + (%uri-string (->uri uri 'URI->STRING))) (define (uri->symbol uri) (utf8-string->symbol (uri->string uri))) (define (write-uri uri port) - (guarantee-port port 'WRITE-URI) - (write-string (uri-string (->uri uri 'WRITE-URI)) port)) + (write-string (uri->string uri) port)) (define (%write-uri scheme authority path query fragment port) (if scheme