From: Chris Hanson Date: Mon, 30 May 2005 04:42:36 +0000 (+0000) Subject: Add support for partial URI parsing. This is useful for completion. X-Git-Tag: 20090517-FFI~1294 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bebc651cdfe1b8012ff6e760b30b963a19a82b23;p=mit-scheme.git Add support for partial URI parsing. This is useful for completion. --- diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index bb5584136..dde9d1fc3 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.549 2005/05/30 04:10:29 cph Exp $ +$Id: runtime.pkg,v 14.550 2005/05/30 04:42:24 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology @@ -4780,6 +4780,7 @@ USA. 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 @@ -4789,6 +4790,7 @@ USA. error:not-uri-scheme error:not-uri-userinfo guarantee-absolute-uri + guarantee-partial-uri guarantee-relative-uri guarantee-uri guarantee-uri-authority @@ -4801,10 +4803,20 @@ USA. make-uri-authority merge-uris parse-absolute-uri + parse-partial-uri parse-relative-uri parse-uri + partial-uri->string + partial-uri-authority + partial-uri-fragment + partial-uri-path + partial-uri-query + partial-uri-scheme + partial-uri-state-name + partial-uri? relative-uri? string->absolute-uri + string->partial-uri string->relative-uri string->uri test-merge-uris @@ -4864,6 +4876,7 @@ USA. uri? url:char-set:unreserved url:encode-string + write-partial-uri write-uri)) (define-package (runtime postgresql) diff --git a/v7/src/runtime/url.scm b/v7/src/runtime/url.scm index bc9c41068..96cfca678 100644 --- a/v7/src/runtime/url.scm +++ b/v7/src/runtime/url.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: url.scm,v 1.26 2005/05/30 02:48:55 cph Exp $ +$Id: url.scm,v 1.27 2005/05/30 04:42:36 cph Exp $ Copyright 2000,2001,2003,2004,2005 Massachusetts Institute of Technology @@ -1039,4 +1039,221 @@ USA. (write n-errors) (write-string "No")) (write-string " errors found") - (newline)))) \ No newline at end of file + (newline)))) + +;;;; Partial URIs + +(define (string->partial-uri string #!optional start end puri) + (parse-partial-uri (open-input-string string start end) puri)) + +(define (parse-partial-uri port #!optional puri) + (let ((puri + (if (default-object? puri) + (make-partial-uri ppu:start (open-output-string) #f #f #f #f #f) + (begin + (guarantee-partial-uri puri 'PARSE-PARTIAL-URI) + puri)))) + ((partial-uri-state puri) port puri))) + +(define (partial-uri->string puri) + (call-with-output-string + (lambda (port) + (write-partial-uri puri port)))) + +(define (write-partial-uri puri port) + (guarantee-partial-uri puri 'WRITE-PARTIAL-URI) + (let ((write-component + (lambda (component) + (if component + (write-string component port))))) + (write-component (partial-uri-scheme puri)) + (write-component (partial-uri-authority puri)) + (write-component (partial-uri-path puri)) + (write-component (partial-uri-query puri)) + (write-component (partial-uri-fragment puri)))) + +(define-record-type + (make-partial-uri state buffer scheme authority path query fragment) + partial-uri? + (state partial-uri-state set-partial-uri-state!) + (buffer partial-uri-buffer) + (scheme partial-uri-scheme set-partial-uri-scheme!) + (authority partial-uri-authority set-partial-uri-authority!) + (path partial-uri-path set-partial-uri-path!) + (query partial-uri-query set-partial-uri-query!) + (fragment partial-uri-fragment set-partial-uri-fragment!)) + +(define-guarantee partial-uri "partial URI") + +(define (partial-uri-state-name puri) + (let ((state (partial-uri-state puri))) + (let loop ((ps state-names)) + (if (not (pair? ps)) + (error "Unknown partial-URI state:" state)) + (if (eq? (cdar ps) state) + (caar ps) + (loop (cdr ps)))))) + +(define (define-state-name name state) + (let loop ((ps state-names)) + (if (pair? ps) + (if (eq? (caar ps) name) + (set-cdr! (car ps) state) + (loop (cdr ps))) + (begin + (set! state-names (cons (cons name state) state-names)) + unspecific)))) + +(define state-names '()) + +(define (accumulate char puri) + (write-char char (partial-uri-buffer puri))) + +(define (buffer-string puri) + (get-output-string! (partial-uri-buffer puri))) + +(define (buffer->scheme puri) + (set-partial-uri-scheme! puri (buffer-string puri))) + +(define (buffer->authority puri) + (set-partial-uri-authority! puri (buffer-string puri))) + +(define (buffer->path puri) + (set-partial-uri-path! puri (buffer-string puri))) + +(define (buffer->query puri) + (set-partial-uri-query! puri (buffer-string puri))) + +(define (buffer->fragment puri) + (set-partial-uri-fragment! puri (buffer-string puri))) + +(define-syntax define-ppu-state + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(SYMBOL + (SYMBOL * DATUM)) (cdr form)) + (let* ((state-name (cadr form)) + (name (symbol 'PPU: state-name)) + (clauses (cddr form)) + (expand-transition + (lambda (clause) + (append + (append-map + (lambda (action) + (if (syntax-match? '('SET SYMBOL) action) + `((,(symbol 'BUFFER-> (cadr action)) PURI)) + '())) + (cdr clause)) + (if (eq? (car clause) 'EOF) + '() + '((ACCUMULATE CHAR PURI))) + (append-map + (lambda (action) + (if (syntax-match? '('SET-AFTER SYMBOL) action) + `((,(symbol 'BUFFER-> (cadr action)) PURI)) + '())) + (cdr clause)) + (append-map + (lambda (action) + (cond ((symbol? action) + `((,(symbol 'PPU: action) PORT PURI))) + ((or (syntax-match? '('SET SYMBOL) action) + (syntax-match? '('SET-AFTER SYMBOL) action)) + '()) + (else + (error "Unknown action:" action)))) + (cdr clause)) + (if (eq? (car clause) 'EOF) + '(PURI) + '()))))) + `(BEGIN + (DEFINE (,name PORT PURI) + (SET-PARTIAL-URI-STATE! PURI ,name) + (LET ((CHAR (READ-CHAR PORT))) + (COND ((EOF-OBJECT? CHAR) + ,@(expand-transition + (or (assq 'EOF clauses) + '(EOF)))) + ,@(append-map + (lambda (clause) + (let ((key (car clause))) + (cond ((eq? key 'EOF) + '()) + ((fix:= (string-length (symbol-name key)) + 1) + `(((CHAR=? CHAR + ,(string-ref (symbol-name key) + 0)) + ,@(expand-transition clause)))) + (else + `(((CHAR-SET-MEMBER? + ,(symbol 'CHAR-SET:URI- key) + CHAR) + ,@(expand-transition clause))))))) + clauses) + (ELSE + (UNREAD-CHAR CHAR PORT) + #F)))) + (DEFINE-STATE-NAME ',state-name ,name))) + (ill-formed-syntax form))))) + +(define-ppu-state start + (/ init-slash) + (alpha scheme) + (segment-nc segment-nz-nc) + (? (set path) query) + (|#| (set path) fragment) + (EOF (set path))) + +(define-ppu-state scheme + (scheme scheme) + (segment-nc segment-nz-nc) + (: (set-after scheme) hier-part) + (/ path) + (? (set path) query) + (|#| (set path) fragment) + (EOF (set path))) + +(define-ppu-state segment-nz-nc + (segment-nc segment-nz-nc) + (/ path) + (? (set path) query) + (|#| (set path) fragment) + (EOF (set path))) + +(define-ppu-state hier-part + (segment path) + (/ init-slash) + (? (set path) query) + (|#| (set path) fragment) + (EOF (set path))) + +(define-ppu-state init-slash + (segment path) + (/ authority) + (? (set path) query) + (|#| (set path) fragment) + (EOF (set path))) + +(define-ppu-state authority + (opaque-auth authority) + (/ (set authority) path) + (? (set authority) query) + (|#| (set authority) fragment) + (EOF (set authority))) + +(define-ppu-state path + (segment path) + (/ path) + (? (set path) query) + (|#| (set path) fragment) + (EOF (set path))) + +(define-ppu-state query + (query query) + (|#| (set query) fragment) + (EOF (set query))) + +(define-ppu-state fragment + (fragment fragment) + (EOF (set fragment))) \ No newline at end of file