From d141ce64d4a0d68d866383845c642afdf81a1b6d Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 31 Jan 2006 17:58:54 +0000 Subject: [PATCH] Intern URIs so that equality can be tested using EQ?. --- v7/src/runtime/url.scm | 171 ++++++++++++++++++++++------------------- 1 file changed, 91 insertions(+), 80 deletions(-) diff --git a/v7/src/runtime/url.scm b/v7/src/runtime/url.scm index b0797939b..00fab9212 100644 --- a/v7/src/runtime/url.scm +++ b/v7/src/runtime/url.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: url.scm,v 1.38 2006/01/31 06:47:47 cph Exp $ +$Id: url.scm,v 1.39 2006/01/31 17:58:54 cph Exp $ Copyright 2000,2001,2003,2004,2005,2006 Massachusetts Institute of Technology @@ -31,19 +31,20 @@ USA. (declare (usual-integrations)) (define-record-type - (%make-uri scheme authority path query fragment) + (%%make-uri scheme authority path query fragment string) uri? - (scheme uri-scheme set-uri-scheme!) + (scheme uri-scheme) (authority uri-authority) (path uri-path) (query uri-query) - (fragment uri-fragment set-uri-fragment!)) + (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))) @@ -62,6 +63,17 @@ USA. query fragment))) +(define (%make-uri scheme authority path query fragment) + (let ((string + (call-with-output-string + (lambda (port) + (%write-uri scheme authority path query fragment port))))) + (hash-table/intern! interned-uris string + (lambda () + (%%make-uri scheme authority path query fragment string))))) + +(define interned-uris) + (define (absolute-uri? object) (and (uri? object) (uri-absolute? object))) @@ -110,7 +122,7 @@ USA. (not (path-absolute? path))) (define-record-type - (%make-uri-authority userinfo host port) + (%%make-uri-authority userinfo host port) uri-authority? (userinfo uri-authority-userinfo) (host uri-authority-host) @@ -120,7 +132,10 @@ USA. (standard-unparser-method 'URI-AUTHORITY (lambda (authority port) (write-char #\space port) - (write-authority authority port)))) + (write (call-with-output-string + (lambda (port) + (write-authority authority port))) + port)))) (define (make-uri-authority userinfo host port) (if userinfo (guarantee-uri-userinfo userinfo 'MAKE-URI-AUTHORITY)) @@ -128,6 +143,16 @@ USA. (if port (guarantee-uri-port port 'MAKE-URI-AUTHORITY)) (%make-uri-authority userinfo host port)) +(define (%make-uri-authority userinfo host port) + (hash-table/intern! interned-uri-authorities + (call-with-output-string + (lambda (output) + (%write-authority userinfo host port output))) + (lambda () + (%%make-uri-authority userinfo host port)))) + +(define interned-uri-authorities) + (define (uri-userinfo? object) (and (string? object) (complete-match parser:userinfo object))) @@ -150,37 +175,15 @@ USA. (let ((buffer (string->parser-buffer string start end))) (and (matcher buffer) (not (peek-parser-buffer-char buffer))))) - + (define (uri=? u1 u2) - (let ((u1 (->uri u1 'URI=?)) - (u2 (->uri u2 'URI=?))) - (and (eq? (uri-scheme u1) (uri-scheme u2)) - (%component=? %uri-authority=? (uri-authority u1) (uri-authority u2)) - (let loop ((p1 (uri-path u1)) (p2 (uri-path u2))) - (if (pair? p1) - (and (pair? p2) - (string=? (car p1) (car p2)) - (loop (cdr p1) (cdr p2))) - (null? p2))) - (%component=? string=? (uri-query u1) (uri-query u2)) - (%component=? string=? (uri-fragment u1) (uri-fragment u2))))) + (eq? (->uri u1 'URI=?) + (->uri u2 'URI=?))) (define (uri-authority=? a1 a2) (guarantee-uri-authority a1 'URI-AUTHORITY=?) (guarantee-uri-authority a2 'URI-AUTHORITY=?) - (%uri-authority=? a1 a2)) - -(define (%uri-authority=? a1 a2) - (and (%component=? string=? - (uri-authority-userinfo a1) - (uri-authority-userinfo a2)) - (string=? (uri-authority-host a1) (uri-authority-host a2)) - (%component=? = (uri-authority-port a1) (uri-authority-port a2)))) - -(define (%component=? predicate x1 x2) - (if x1 - (and x2 (predicate x1 x2)) - (not x2))) + (eq? a1 a2)) (define (uri->alist uri) `(,@(if (uri-scheme uri) @@ -297,15 +300,19 @@ USA. (lambda (form environment) environment (if (syntax-match? '(SYMBOL) (cdr form)) - (let* ((root (cadr form))) + (let* ((root (cadr form)) + (parser (symbol 'PARSE- root))) `(DEFINE (,(symbol '-> root) OBJECT #!OPTIONAL CALLER) - (IF (,(symbol root '?) OBJECT) - OBJECT - (OR (COMPLETE-PARSE - ,(symbol 'PARSE- root) - (OR (->PARSER-BUFFER OBJECT) - (,(symbol 'ERROR:NOT- root) OBJECT CALLER))) - (ERROR:BAD-RANGE-ARGUMENT OBJECT 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) @@ -329,7 +336,11 @@ USA. (%string->uri parse-relative-uri string start end 'STRING->RELATIVE-URI)) (define (%string->uri parser string start end caller) - (or (complete-parse parser (string->parser-buffer string start end)) + (or (and (string? string) + (default-object? start) + (default-object? end) + (hash-table/get interned-uris string #f)) + (complete-parse parser (string->parser-buffer string start end)) (error:bad-range-argument string caller))) (define (complete-parse parser buffer) @@ -541,61 +552,58 @@ USA. ;;;; Output (define (uri->string uri) - (guarantee-uri uri 'URI->STRING) - (call-with-output-string - (lambda (port) - (%write-uri uri port)))) + (uri-string (->uri uri 'URI->STRING))) (define (uri->symbol uri) (utf8-string->symbol (uri->string uri))) (define (write-uri uri port) - (guarantee-uri uri 'WRITE-URI) (guarantee-port port 'WRITE-URI) - (%write-uri uri port)) + (write-string (uri-string (->uri uri 'WRITE-URI)) port)) -(define (%write-uri uri port) - (if (uri-scheme uri) +(define (%write-uri scheme authority path query fragment port) + (if scheme (begin - (write (uri-scheme uri) port) + (write scheme port) (write-char #\: port))) - (if (uri-authority uri) - (write-authority (uri-authority uri) port)) - (let ((path (uri-path uri))) - (if (pair? path) - (begin - (if (uri-scheme uri) - (write-segment (car path) port) - (write-encoded (car path) char-set:uri-segment-nc port)) - (for-each (lambda (segment) - (write-char #\/ port) - (write-segment segment port)) - (cdr path))))) - (if (uri-query uri) + (if authority + (write-authority authority port)) + (if (pair? path) + (begin + (if scheme + (write-segment (car path) port) + (write-encoded (car path) char-set:uri-segment-nc port)) + (for-each (lambda (segment) + (write-char #\/ port) + (write-segment segment port)) + (cdr path)))) + (if query (begin (write-char #\? port) - (write-encoded (uri-query uri) char-set:uri-query port))) - (if (uri-fragment uri) + (write-encoded query char-set:uri-query port))) + (if fragment (begin (write-char #\# port) - (write-encoded (uri-fragment uri) char-set:uri-fragment port)))) + (write-encoded fragment char-set:uri-fragment port)))) (define (write-authority authority port) - (write-string "//" port) - (if (uri-authority-userinfo authority) + (%write-authority (uri-authority-userinfo authority) + (uri-authority-host authority) + (uri-authority-port authority) + port)) + +(define (%write-authority userinfo host port output) + (write-string "//" output) + (if userinfo (begin - (write-encoded (uri-authority-userinfo authority) - char-set:uri-userinfo - port) - (write-char #\@ port))) - (if (uri-authority-host authority) - (write-encoded (uri-authority-host authority) - char-set:uri-opaque-auth - port)) - (if (uri-authority-port authority) + (write-encoded userinfo char-set:uri-userinfo output) + (write-char #\@ output))) + (if host + (write-encoded host char-set:uri-opaque-auth output)) + (if port (begin - (write-char #\: port) - (write (uri-authority-port authority) port)))) + (write-char #\: output) + (write port output)))) (define (write-segment segment port) (write-encoded segment char-set:uri-segment port)) @@ -901,6 +909,9 @@ USA. (set! parser:query (component-parser-* char-set:uri-query)) (set! parser:fragment (component-parser-* char-set:uri-fragment)) + (set! interned-uris (make-string-hash-table)) + (set! interned-uri-authorities (make-string-hash-table)) + ;; backwards compatibility: (set! url:char-set:unreserved (char-set-union char-set:uri-alpha -- 2.25.1