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 bb55841366cb1ec7d9369ea0f97ddb73bfbadeac..dde9d1fc334c5844d82159881cb6f5c9a0d3ecdf 100644 (file)
--- 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 bc9c41068a8ebd9b64fc2ba4b146a16095b7cb77..96cfca67831521f371d1dc71bda45386616704b1 100644 (file)
--- 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))))
+\f
+;;;; 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 <partial-uri>
+    (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")
+\f
+(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)))
+\f
+(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)))))
+\f
+(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