Restructure the URL completion code to clean it up a bit. Change the

completer so that it doesn't do completion on URL protocols.  Instead,
if there isn't a protocol prefix on the string, it assumes the
protocol of the default URL, and completes the string relative to that
URL.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 49fd5325462d854195e1c29e88d3ef3dca0e997c..10db2a748de68ca759eadfd1beddea4885fb577a 100644 (file)
--- a/v7/src/imail/imail-core.scm
+++ b/v7/src/imail/imail-core.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-core.scm,v 1.79 2000/05/22 02:17:35 cph Exp $
+;;; $Id: imail-core.scm,v 1.80 2000/05/22 03:01:13 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -53,8 +53,11 @@
 ;; Return the body of URL as a string.
 (define-generic url-body (url))
 
+(define (make-url-string protocol body)
+  (string-append protocol ":" body))
+
 (define (url->string url)
-  (string-append (url-protocol url) ":" (url-body url)))
+  (make-url-string (url-protocol url) (url-body url)))
 
 (define-method write-instance ((url <url>) port)
   (write-instance-helper 'URL url port
@@ -76,15 +79,15 @@
 (define (parse-url-string string get-default-url)
   (let ((colon (string-find-next-char string #\:)))
     (if colon
-       (%parse-url-string (string-tail string (fix:+ colon 1))
+       (parse-url-body (string-tail string (fix:+ colon 1))
                           (get-default-url (string-head string colon)))
-       (%parse-url-string string (get-default-url #f)))))
+       (parse-url-body string (get-default-url #f)))))
 
 ;; Protocol-specific parsing.  Dispatch on the class of DEFAULT-URL.
 ;; Each method is responsible for calling INTERN-URL on the result of
 ;; the parse, and returning the interned URL.  Illegal syntax in
 ;; STRING must cause an error to be signalled.
-(define-generic %parse-url-string (string default-url))
+(define-generic parse-url-body (string default-url))
 
 (define (intern-url url)
   (let ((string (url->string url)))
@@ -120,33 +123,17 @@
 
 (define (url-complete-string string get-default-url
                             if-unique if-not-unique if-not-found)
-  (let ((colon (string-find-next-char string #\:)))
-    (if colon
-       (let ((name (string-head string colon)))
-         (if (url-protocol-name? name)
-             (let ((prepend
-                    (lambda (string) (string-append name ":" string))))
-               (%url-complete-string (string-tail string (fix:+ colon 1))
-                                     (get-default-url name)
-                                     (lambda (string)
-                                       (if-unique (prepend string)))
-                                     (lambda (prefix get-completions)
-                                       (if-not-unique
-                                        (prepend prefix)
-                                        (lambda ()
-                                          (map prepend (get-completions)))))
-                                     if-not-found))
-             (if-not-found)))
-       (let ((colonify (lambda (name) (string-append name ":"))))
-         ((ordered-string-vector-completer
-           (hash-table/ordered-key-vector url-protocols string<?))
-          string
-          (lambda (name)
-            (if-unique (colonify name)))
-          (lambda (prefix get-completions)
-            (if-not-unique prefix
-                           (lambda () (map colonify (get-completions)))))
-          if-not-found)))))
+  (call-with-values (lambda () (url-completion-args string get-default-url))
+    (lambda (body default-url prepend)
+      (if default-url
+         (%url-complete-string body default-url
+           (lambda (body)
+             (if-unique (prepend body)))
+           (lambda (prefix get-completions)
+             (if-not-unique (prepend prefix)
+                            (lambda () (map prepend (get-completions)))))
+           if-not-found)
+         (if-not-found)))))
 
 (define-generic %url-complete-string
     (string default-url if-unique if-not-unique if-not-found))
@@ -155,22 +142,29 @@
 ;; See PARSE-URL-STRING for a description of GET-DEFAULT-URL.
 
 (define (url-string-completions string get-default-url)
-  (let ((colon (string-find-next-char string #\:)))
-    (if colon
-       (let ((name (string-head string colon)))
-         (if (url-protocol-name? name)
-             (map (lambda (string) (string-append name ":" string))
-                  (%url-string-completions
-                   (string-tail string (fix:+ colon 1))
-                   (get-default-url name)))
-             '()))
-       (map (lambda (name) (string-append name ":"))
-            (vector->list
-             ((ordered-string-vector-matches
-               (hash-table/ordered-key-vector url-protocols string<?))
-              string))))))
+  (call-with-values (lambda () (url-completion-args string get-default-url))
+    (lambda (body default-url prepend)
+      (map prepend
+          (if default-url
+              (%url-string-completions body default-url)
+              '())))))
 
 (define-generic %url-string-completions (string default-url))
+
+(define (url-completion-args string get-default-url)
+  (let ((colon (string-find-next-char string #\:))
+       (make-prepend
+        (lambda (protocol)
+          (lambda (body)
+            (make-url-string protocol body)))))
+    (if colon
+       (let ((protocol (string-head string colon)))
+         (values (string-tail string (fix:+ colon 1))
+                 (and (url-protocol-name? protocol)
+                      (get-default-url protocol))
+                 (make-prepend protocol)))
+       (let ((url (get-default-url #f)))
+         (values string url (make-prepend (url-protocol url)))))))
 \f
 ;;;; Server operations
 

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 4de06cc01e3c2ad8e9ee2273f10a3fa28e37f4ea..f97bc8b60d631d96856abee59593730818f47b59 100644 (file)
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.63 2000/05/22 02:17:41 cph Exp $
+;;; $Id: imail-imap.scm,v 1.64 2000/05/22 03:01:18 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -68,11 +68,14 @@
        (string-ci=? (imap-url-host url1) (imap-url-host url2))
        (= (imap-url-port url1) (imap-url-port url2))))
 
-(define-method %parse-url-string (string default-url)
-  (or (parse-imap-url-string string default-url)
-      (error:bad-range-argument string 'PARSE-URL-STRING)))
+(define-method parse-url-body (string default-url)
+  (call-with-values (lambda () (parse-imap-url-body string default-url))
+    (lambda (user-id host port mailbox)
+      (if user-id
+         (make-imap-url user-id host port mailbox)
+         (error:bad-range-argument string 'PARSE-URL-BODY)))))
 
-(define parse-imap-url-string
+(define parse-imap-url-body
   (let ((parser
         (let ((//server
                (sequence-parser (noise-parser (string-matcher "//"))
@@ -86,59 +89,60 @@
            imap:parse:enc-mailbox))))
     (lambda (string default-url)
       (let ((pv (parse-string parser string)))
-       (and pv
-            (make-imap-url (or (parser-token pv 'USER-ID)
-                               (imap-url-user-id default-url))
-                           (or (parser-token pv 'HOST)
-                               (imap-url-host default-url))
-                           (cond ((parser-token pv 'PORT) => string->number)
-                                 ((parser-token pv 'HOST) 143)
-                                 (else (imap-url-port default-url)))
-                           (or (parser-token pv 'MAILBOX)
-                               (imap-url-mailbox default-url))))))))
+       (if pv
+           (values (or (parser-token pv 'USER-ID)
+                       (imap-url-user-id default-url))
+                   (or (parser-token pv 'HOST)
+                       (imap-url-host default-url))
+                   (cond ((parser-token pv 'PORT) => string->number)
+                         ((parser-token pv 'HOST) 143)
+                         (else (imap-url-port default-url)))
+                   (or (parser-token pv 'MAILBOX)
+                       (imap-url-mailbox default-url)))
+           (values #f #f #f #f))))))
 \f
 (define-method %url-complete-string
     ((string <string>) (default-url <imap-url>)
                       if-unique if-not-unique if-not-found)
-  (call-with-values
-      (lambda () (parse-imap-completion-url-string string default-url))
+  (call-with-values (lambda () (imap-completion-args string default-url))
     (lambda (mailbox url)
       (if mailbox
          (let ((convert
                 (lambda (mailbox)
-                  (url-body (parse-imap-url-string mailbox url)))))
+                  (make-imap-url-string (imap-url-user-id url)
+                                        (imap-url-host url)
+                                        (imap-url-port url)
+                                        mailbox))))
            (complete-imap-mailbox mailbox url
              (lambda (mailbox)
                (if-unique (convert mailbox)))
              (lambda (prefix get-mailboxes)
-               (if-not-unique (if (string-null? prefix)
-                                  (make-imap-url-string (imap-url-user-id url)
-                                                        (imap-url-host url)
-                                                        (imap-url-port url)
-                                                        "")
-                                  (convert prefix))
+               (if-not-unique (convert prefix)
                               (lambda () (map convert (get-mailboxes)))))
              if-not-found))
          (if-not-found)))))
 
 (define-method %url-string-completions
     ((string <string>) (default-url <imap-url>))
-  (call-with-values
-      (lambda () (parse-imap-completion-url-string string default-url))
+  (call-with-values (lambda () (imap-completion-args string default-url))
     (lambda (mailbox url)
       (if mailbox
          (map (lambda (mailbox)
-                (url-body (parse-imap-url-string mailbox url)))
+                (make-imap-url-string (imap-url-user-id url)
+                                      (imap-url-host url)
+                                      (imap-url-port url)
+                                      mailbox))
               (imap-mailbox-completions mailbox url))
          '()))))
 
-(define (parse-imap-completion-url-string string default-url)
-  (cond ((string-null? string)
-        (values string default-url))
-       ((parse-imap-url-string string default-url)
-        => (lambda (url) (values (imap-url-mailbox url) url)))
-       (else
-        (values #f #f))))
+(define (imap-completion-args string default-url)
+  (if (string-null? string)
+      (values string default-url)
+      (call-with-values (lambda () (parse-imap-url-body string default-url))
+       (lambda (user-id host port mailbox)
+         (if user-id
+             (values mailbox (make-imap-url user-id host port "inbox"))
+             (values #f #f))))))
 
 (define (complete-imap-mailbox mailbox url
                               if-unique if-not-unique if-not-found)

diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 9fad354d4afcf83b870488f8ea916ba1ac5dffe6..9c6014912d590a48adea6f6a11ad879f3c935b2e 100644 (file)
--- a/v7/src/imail/imail-rmail.scm
+++ b/v7/src/imail/imail-rmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-rmail.scm,v 1.34 2000/05/22 02:17:47 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.35 2000/05/22 03:01:24 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -32,7 +32,7 @@
     (lambda (pathname)
       (intern-url (constructor (merge-pathnames pathname))))))
 
-(define-method %parse-url-string ((string <string>) (default-url <rmail-url>))
+(define-method parse-url-body ((string <string>) (default-url <rmail-url>))
   (make-rmail-url (merge-pathnames string (file-url-pathname default-url))))
 
 (define-file-url-completers <rmail-url>

diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index bdba2b2c97136446e7df9c304170151128d16276..fd0d5cb929b6d867818065f08c0b475da7f85411 100644 (file)
--- a/v7/src/imail/imail-umail.scm
+++ b/v7/src/imail/imail-umail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-umail.scm,v 1.28 2000/05/22 02:17:55 cph Exp $
+;;; $Id: imail-umail.scm,v 1.29 2000/05/22 03:01:28 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -32,7 +32,7 @@
     (lambda (pathname)
       (intern-url (constructor (merge-pathnames pathname))))))
 
-(define-method %parse-url-string ((string <string>) (default-url <umail-url>))
+(define-method parse-url-body ((string <string>) (default-url <umail-url>))
   (make-umail-url (merge-pathnames string (file-url-pathname default-url))))
 
 (define-file-url-completers <umail-url>

diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm
index d6aabe5e5797aae5d92908928e93e9bea20cc624..98196dd4363454e1fed619abfa43f1c7fc337858 100644 (file)
--- a/v7/src/imail/imail-util.scm
+++ b/v7/src/imail/imail-util.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-util.scm,v 1.23 2000/05/21 00:03:32 cph Exp $
+;;; $Id: imail-util.scm,v 1.24 2000/05/22 03:01:30 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -297,75 +297,6 @@
 (define derived-port-condition
   (condition-accessor condition-type:derived-port-error 'CONDITION))
 \f
-;;;; Ordered-string-vector completion
-
-(define (hash-table/ordered-key-vector table <)
-  (let ((v (list->vector (hash-table/key-list table))))
-    (sort! v <)
-    v))
-
-(define (ordered-string-vector-completer strings)
-  (lambda (string if-unique if-not-unique if-not-found)
-    (ordered-vector-minimum-match strings string identity-procedure
-                                 string-order (string-prefix-matcher string)
-                                 if-unique if-not-unique if-not-found)))
-
-(define (ordered-string-vector-completer-ci strings)
-  (lambda (string if-unique if-not-unique if-not-found)
-    (ordered-vector-minimum-match strings string identity-procedure
-                                 string-order-ci
-                                 (string-prefix-matcher-ci string)
-                                 if-unique if-not-unique if-not-found)))
-
-(define (ordered-string-vector-matches strings)
-  (lambda (string)
-    (ordered-vector-matches strings string identity-procedure
-                           string-order (string-prefix-matcher string))))
-
-(define (ordered-string-vector-matches-ci strings)
-  (lambda (string)
-    (ordered-vector-matches strings string identity-procedure
-                           string-order-ci
-                           (string-prefix-matcher-ci string))))
-
-(define (string-order x y)
-  (let ((lx (string-length x))
-       (ly (string-length y)))
-    (let ((i (substring-match-forward x 0 lx y 0 ly)))
-      (if (fix:< i lx)
-         (if (fix:< i ly)
-             (if (char<? (string-ref x i) (string-ref y i)) 'LESS 'GREATER)
-             'GREATER)
-         (if (fix:< i ly)
-             'LESS
-             'EQUAL)))))
-
-(define (string-order-ci x y)
-  (let ((lx (string-length x))
-       (ly (string-length y)))
-    (let ((i (substring-match-forward-ci x 0 lx y 0 ly)))
-      (if (fix:< i lx)
-         (if (fix:< i ly)
-             (if (char-ci<? (string-ref x i) (string-ref y i)) 'LESS 'GREATER)
-             'GREATER)
-         (if (fix:< i ly)
-             'LESS
-             'EQUAL)))))
-
-(define (string-prefix-matcher prefix)
-  (let ((l (string-length prefix)))
-    (lambda (x y)
-      (let ((i (string-match-forward x y)))
-       (and (fix:>= i l)
-            i)))))
-
-(define (string-prefix-matcher-ci prefix)
-  (let ((l (string-length prefix)))
-    (lambda (x y)
-      (let ((i (string-match-forward-ci x y)))
-       (and (fix:>= i l)
-            i)))))
-\f
 ;;;; Filename Completion
 
 (define (pathname-complete-string pathname filter