From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 22 May 2000 02:17:58 +0000 (+0000)
Subject: Implement URL completion, and reimplement URL parsing to do sensible
X-Git-Tag: 20090517-FFI~3765
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4e2724f796f647d0b0d21ac872584bd7f59ee134;p=mit-scheme.git

Implement URL completion, and reimplement URL parsing to do sensible
defaulting.  This implementation appears to work but has several minor
problems.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 45310a6e1..49fd53254 100644
--- 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.78 2000/05/20 19:37:03 cph Exp $
+;;; $Id: imail-core.scm,v 1.79 2000/05/22 02:17:35 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -43,15 +43,18 @@
 
 (define-class <url> (<imail-object>))
 
+(define (guarantee-url url procedure)
+  (if (not (url? url))
+      (error:wrong-type-argument url "IMAIL URL" procedure)))
+
 ;; Return the canonical name of URL's protocol as a string.
 (define-generic url-protocol (url))
 
 ;; Return the body of URL as a string.
 (define-generic url-body (url))
 
-(define (guarantee-url url procedure)
-  (if (not (url? url))
-      (error:wrong-type-argument url "IMAIL URL" procedure)))
+(define (url->string url)
+  (string-append (url-protocol url) ":" (url-body url)))
 
 (define-method write-instance ((url <url>) port)
   (write-instance-helper 'URL url port
@@ -59,59 +62,49 @@
       (write-char #\space port)
       (write (url->string url) port))))
 
-(define (make-url protocol body)
-  (string->url (string-append protocol ":" body)))
-
-(define-generic ->url (object))
-(define-method ->url ((url <url>)) url)
-(define-method ->url ((string <string>)) (string->url string))
-
-(define (string->url string)
-  (or (hash-table/get saved-urls string #f)
-      (let ((url
-	     (let ((colon (string-find-next-char string #\:)))
-	       (if (not colon)
-		   (error:bad-range-argument string 'STRING->URL))
-	       ((or (get-url-protocol-parser (string-head string colon))
-		    (error:bad-range-argument string 'STRING->URL))
-		(string-tail string (fix:+ colon 1))))))
-	(hash-table/put! saved-urls string url)
-	url)))
-
-(define (save-url url)
+;; Return a string that concisely identifies URL, for use in the
+;; presentation layer.
+(define-generic url-presentation-name (url))
+
+;; Convert STRING to a URL.  GET-DEFAULT-URL is a procedure of one
+;; argument that returns a URL that is used to fill in defaults if
+;; STRING is a specification for a partial URL.  GET-DEFAULT-URL is
+;; called with #F as its first argument to return a default URL to be
+;; used if STRING doesn't explicitly specify a protocol.  Otherwise,
+;; it is called with a protocol name as its first argument to return a
+;; protocol-specific default.
+(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))
+			   (get-default-url (string-head string colon)))
+	(%parse-url-string 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 (intern-url url)
   (let ((string (url->string url)))
-    (or (hash-table/get saved-urls string #f)
+    (or (hash-table/get interned-urls string #f)
 	(begin
-	  (hash-table/put! saved-urls string url)
+	  (hash-table/put! interned-urls string url)
 	  url))))
 
-(define saved-urls
+(define interned-urls
   (make-string-hash-table))
 
-(define (url->string url)
-  (string-append (url-protocol url) ":" (url-body url)))
-
-(define (define-url-protocol name class parser completer completions)
+(define (define-url-protocol name class)
   (define-method url-protocol ((url class)) url name)
-  (hash-table/put! url-protocols
-		   (string-downcase name)
-		   (vector parser completer completions)))
+  (hash-table/put! url-protocols (string-downcase name) class))
 
-(define (get-url-protocol-parser name) (get-url-protocol-item name 0))
-(define (get-url-protocol-completer name) (get-url-protocol-item name 1))
-(define (get-url-protocol-completions name) (get-url-protocol-item name 2))
-
-(define (get-url-protocol-item name index)
-  (let ((v (hash-table/get url-protocols (string-downcase name) #f)))
-    (and v
-	 (vector-ref v index))))
+(define (url-protocol-name? name)
+  (hash-table/get url-protocols (string-downcase name) #f))
 
 (define url-protocols
   (make-string-hash-table))
-
-;; Return a string that concisely identifies URL, for use in the
-;; presentation layer.
-(define-generic url-presentation-name (url))
 
 ;; Do completion on URL-STRING, which is a partially-specified URL.
 ;; Tail-recursively calls one of the three procedure arguments, as
@@ -123,29 +116,31 @@
 ;; completions.  If URL-STRING has no completions, IF-NOT-FOUND is
 ;; called with no arguments.
 
-(define (url-complete-string url-string if-unique if-not-unique if-not-found)
-  (let ((colon (string-find-next-char url-string #\:)))
+;; See PARSE-URL-STRING for a description of GET-DEFAULT-URL.
+
+(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 ((prepend
-	       (let ((prefix (string-head url-string (fix:+ colon 1))))
-		 (lambda (string)
-		   (string-append prefix string)))))
-	  (let ((completer
-		 (get-url-protocol-completer (string-head url-string colon))))
-	    (if completer
-		(completer (string-tail url-string (fix:+ colon 1))
-			   (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 ((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<?))
-	   url-string
+	   string
 	   (lambda (name)
 	     (if-unique (colonify name)))
 	   (lambda (prefix get-completions)
@@ -153,24 +148,29 @@
 			    (lambda () (map colonify (get-completions)))))
 	   if-not-found)))))
 
-;; Return a list of the completions for URL-STRING.
+(define-generic %url-complete-string
+    (string default-url if-unique if-not-unique if-not-found))
 
-(define (url-string-completions url-string)
-  (let ((colon (string-find-next-char url-string #\:)))
+;; Return a list of the completions for STRING.
+;; 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 ((get-completions
-	       (get-url-protocol-completions (string-head url-string colon))))
-	  (if get-completions
-	      (map (let ((prefix (string-head url-string (fix:+ colon 1))))
-		     (lambda (string)
-		       (string-append prefix string)))
-		   (get-completions (string-tail url-string (fix:+ colon 1))))
+	(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<?))
-	       url-string))))))
+	       string))))))
+
+(define-generic %url-string-completions (string default-url))
 
 ;;;; Server operations
 
@@ -179,7 +179,7 @@
 ;; already exists or can't be created.
 
 (define (create-folder url)
-  (%create-folder (->url url)))
+  (%create-folder url))
 
 (define-generic %create-folder (url))
 
@@ -188,12 +188,11 @@
 ;; exist or if it can't be deleted.
 
 (define (delete-folder url)
-  (let ((url (->url url)))
-    (let ((folder (get-memoized-folder url)))
-      (if folder
-	  (close-folder folder)))
-    (unmemoize-folder url)
-    (%delete-folder url)))
+  (let ((folder (get-memoized-folder url)))
+    (if folder
+	(close-folder folder)))
+  (unmemoize-folder url)
+  (%delete-folder url))
 
 (define-generic %delete-folder (url))
 
@@ -205,13 +204,11 @@
 ;; another.  It only allows changing the name of an existing folder.
 
 (define (rename-folder url new-url)
-  (let ((url (->url url))
-	(new-url (->url new-url)))
-    (let ((folder (get-memoized-folder url)))
-      (if folder
-	  (close-folder folder)))
-    (unmemoize-folder url)
-    (%rename-folder url new-url)))
+  (let ((folder (get-memoized-folder url)))
+    (if folder
+	(close-folder folder)))
+  (unmemoize-folder url)
+  (%rename-folder url new-url))
 
 (define-generic %rename-folder (url new-url))
 
@@ -220,7 +217,7 @@
 ;; messages.  Unspecified result.
 
 (define (append-message message url)
-  (%append-message message (->url url)))
+  (%append-message message url))
 
 (define-generic %append-message (message url))
 
@@ -249,9 +246,6 @@
   (if (not (folder? folder))
       (error:wrong-type-argument folder "IMAIL folder" procedure)))
 
-(define-method ->url ((folder <folder>))
-  (folder-url folder))
-
 (define (folder-modified! folder type . parameters)
   (without-interrupts
    (lambda ()
@@ -292,9 +286,8 @@
 ;; Open the folder named URL.
 
 (define (open-folder url)
-  (let ((url (->url url)))
-    (or (get-memoized-folder url)
-	(memoize-folder (%open-folder url)))))
+  (or (get-memoized-folder url)
+      (memoize-folder (%open-folder url))))
 
 (define-generic %open-folder (url))
 
diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 06b0758e7..cc71678ed 100644
--- a/v7/src/imail/imail-file.scm
+++ b/v7/src/imail/imail-file.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-file.scm,v 1.30 2000/05/20 19:39:14 cph Exp $
+;;; $Id: imail-file.scm,v 1.31 2000/05/22 02:17:39 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -28,36 +28,35 @@
   (pathname define accessor))
 
 (define-method url-body ((url <file-url>))
-  (pathname->short-name (file-url-pathname url)))
+  (->namestring (file-url-pathname url)))
 
 (define-method url-presentation-name ((url <file-url>))
   (file-namestring (file-url-pathname url)))
 
-(define ((file-url-completer filter)
-	 string if-unique if-not-unique if-not-found)
-  (pathname-complete-string (short-name->pathname string) filter
-    (lambda (string)
-      (if-unique (pathname->short-name string)))
-    (lambda (prefix get-completions)
-      (if-not-unique (pathname->short-name prefix)
-		     (lambda () (map pathname->short-name (get-completions)))))
-    if-not-found))
-
-(define ((file-url-completions filter) string)
-  (map pathname->short-name
-       (pathname-completions-list (short-name->pathname string) filter)))
-
-(define (file-suffix-filter suffix)
-  (let ((suffix (string-append "." suffix)))
-    (let ((l (string-length suffix)))
-      (lambda (pathname)
-	(let ((string (file-namestring pathname)))
-	  (let ((i (string-search-forward suffix string)))
-	    (and i
-		 (fix:> i 0)
-		 (let ((i (fix:+ i l)))
-		   (or (fix:= i (string-length string))
-		       (char=? #\. (string-ref string i)))))))))))
+(define (define-file-url-completers class filter)
+  (define-method %url-complete-string
+      ((string <string>) (default-url class)
+			 if-unique if-not-unique if-not-found)
+    (pathname-complete-string
+     (merge-pathnames string (file-url-pathname default-url))
+     filter
+     (lambda (string)
+       (if-unique (->namestring string)))
+     (lambda (prefix get-completions)
+       (if-not-unique (->namestring prefix)
+		      (lambda () (map ->namestring (get-completions)))))
+     if-not-found))
+  (define-method %url-string-completions
+      ((string <string>) (default-url class))
+    (map ->namestring
+	 (pathname-completions-list
+	  (merge-pathnames string (file-url-pathname default-url))
+	  filter))))
+
+(define ((file-type-filter type) pathname)
+  (let ((type* (pathname-type pathname)))
+    (and type*
+	 (string=? type* type))))
 
 ;;;; Server operations
 
diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index a076e6223..4de06cc01 100644
--- 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.62 2000/05/20 19:09:49 cph Exp $
+;;; $Id: imail-imap.scm,v 1.63 2000/05/22 02:17:41 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -34,54 +34,29 @@
   ;; Name of mailbox to access.
   (mailbox define accessor))
 
-(define (make-imap-url user-id host port mailbox)
-  (save-url (%make-imap-url user-id host port mailbox)))
-
-(define-url-protocol "imap" <imap-url>
-  (lambda (string)
-    (let ((pv
-	   (or (parse-string imap:parse:imail-url string)
-	       (error:bad-range-argument string 'STRING->URL))))
-      (%make-imap-url (parser-token pv 'USER-ID)
-		      (parser-token pv 'HOST)
-		      (let ((port (parser-token pv 'PORT)))
-			(and port
-			     (string->number port)))
-		      (parser-token pv 'MAILBOX)))))
-
-(define %make-imap-url
+(define-url-protocol "imap" <imap-url>)
+
+(define make-imap-url
   (let ((constructor
 	 (instance-constructor <imap-url> '(USER-ID HOST PORT MAILBOX))))
     (lambda (user-id host port mailbox)
-      (if (and user-id host port mailbox)
-	  (constructor user-id host port mailbox)
-	  (let ((default (imail-default-imap-url)))
-	    (constructor (or user-id (imap-url-user-id default))
-			 (or host (imap-url-host default))
-			 (or port (imap-url-port default))
-			 (or mailbox (imap-url-mailbox default))))))))
-
-(define imap:parse:imail-url
-  (let ((//server
-	 (sequence-parser (noise-parser (string-matcher "//"))
-			  (imap:server-parser #f)))
-	(/mbox
-	 (sequence-parser (noise-parser (string-matcher "/"))
-			  (optional-parser imap:parse:enc-mailbox))))
-    (alternatives-parser
-     (sequence-parser //server (optional-parser /mbox))
-     /mbox
-     imap:parse:enc-mailbox)))
+      (intern-url (constructor user-id host port mailbox)))))
 
 (define-method url-body ((url <imap-url>))
+  (make-imap-url-string (imap-url-user-id url)
+			(imap-url-host url)
+			(imap-url-port url)
+			(imap-url-mailbox url)))
+
+(define (make-imap-url-string user-id host port mailbox)
   (string-append "//"
-		 (url:encode-string (imap-url-user-id url))
+		 (url:encode-string user-id)
 		 "@"
-		 (imap-url-host url)
+		 host
 		 ":"
-		 (number->string (imap-url-port url))
+		 (number->string port)
 		 "/"
-		 (url:encode-string (imap-url-mailbox url))))
+		 (url:encode-string mailbox)))
 
 (define-method url-presentation-name ((url <imap-url>))
   (imap-url-mailbox url))
@@ -92,6 +67,98 @@
   (and (string=? (imap-url-user-id url1) (imap-url-user-id url2))
        (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 parse-imap-url-string
+  (let ((parser
+	 (let ((//server
+		(sequence-parser (noise-parser (string-matcher "//"))
+				 (imap:server-parser #f)))
+	       (/mbox
+		(sequence-parser (noise-parser (string-matcher "/"))
+				 (optional-parser imap:parse:enc-mailbox))))
+	   (alternatives-parser
+	    (sequence-parser //server (optional-parser /mbox))
+	    /mbox
+	    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))))))))
+
+(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))
+    (lambda (mailbox url)
+      (if mailbox
+	  (let ((convert
+		 (lambda (mailbox)
+		   (url-body (parse-imap-url-string mailbox url)))))
+	    (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))
+			       (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))
+    (lambda (mailbox url)
+      (if mailbox
+	  (map (lambda (mailbox)
+		 (url-body (parse-imap-url-string mailbox url)))
+	       (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 (complete-imap-mailbox mailbox url
+			       if-unique if-not-unique if-not-found)
+  (if (string-null? mailbox)
+      (if-not-unique mailbox
+		     (lambda () (imap-mailbox-completions mailbox url)))
+      (let ((responses (imap-mailbox-completions mailbox url)))
+	(cond ((not (pair? responses))
+	       (if-not-found))
+	      ((pair? (cdr responses))
+	       (if-not-unique (string-greatest-common-prefix responses)
+			      (lambda () responses)))
+	      (else
+	       (if-unique (car responses)))))))
+
+(define (imap-mailbox-completions mailbox url)
+  (map imap:response:list-mailbox
+       (with-open-imap-connection url
+	 (lambda (connection)
+	   (imap:command:list connection "" (string-append mailbox "*"))))))
 
 ;;;; Server connection
 
@@ -734,8 +801,8 @@
 
 (define (imap:command:capability connection)
   (imap:response:capabilities
-   (imap:command:single-response imap:response:capability?
-				 connection 'CAPABILITY)))
+   (imap:command:single-response imap:response:capability? connection
+				 'CAPABILITY)))
 
 (define (imap:command:login connection user-id passphrase)
   ((imail-message-wrapper "Logging in as " user-id)
@@ -746,34 +813,29 @@
   ((imail-message-wrapper "Select mailbox " mailbox)
    (lambda ()
      (imap:response:ok?
-      (imap:command:no-response-1 connection 'SELECT
-				  (adjust-mailbox-name connection mailbox))))))
+      (imap:command:no-response-1 connection 'SELECT mailbox)))))
 
 (define (imap:command:fetch connection index items)
-  (imap:command:single-response imap:response:fetch?
-				connection 'FETCH (+ index 1) items))
+  (imap:command:single-response imap:response:fetch? connection
+				'FETCH (+ index 1) items))
 
 (define (imap:command:uid-fetch connection uid items)
-  (imap:command:single-response imap:response:fetch?
-				connection 'UID 'FETCH uid items))
+  (imap:command:single-response imap:response:fetch? connection
+				'UID 'FETCH uid items))
 
 (define (imap:command:fetch-all connection items)
-  (imap:command:multiple-response imap:response:fetch?
-				  connection 'FETCH
-				  (cons 'ATOM "1:*")
-				  items))
+  (imap:command:multiple-response imap:response:fetch? connection
+				  'FETCH (cons 'ATOM "1:*") items))
 
 (define (imap:command:fetch-range connection start end items)
-  (imap:command:multiple-response imap:response:fetch?
-				  connection 'FETCH
-				  (cons 'ATOM
-					(string-append
-					 (number->string (+ start 1))
-					 ":"
-					 (if end
-					     (number->string end)
-					     "*")))
-				  items))
+  (imap:command:multiple-response
+   imap:response:fetch? connection
+   'FETCH
+   (cons 'ATOM
+	 (string-append (number->string (+ start 1))
+			":"
+			(if end (number->string end) "*")))
+   items))
 
 (define (imap:command:uid-store-flags connection uid flags)
   (imap:command:no-response connection 'UID 'STORE uid 'FLAGS flags))
@@ -782,48 +844,35 @@
   ((imail-message-wrapper "Expunging messages")
    (lambda ()
      (imap:command:no-response connection 'EXPUNGE))))
-
+
 (define (imap:command:noop connection)
   (imap:command:no-response connection 'NOOP))
 
 (define (imap:command:create connection mailbox)
-  (imap:command:no-response connection 'CREATE
-			    (adjust-mailbox-name connection mailbox)))
+  (imap:command:no-response connection 'CREATE mailbox))
 
 (define (imap:command:delete connection mailbox)
-  (imap:command:no-response connection 'DELETE
-			    (adjust-mailbox-name connection mailbox)))
+  (imap:command:no-response connection 'DELETE mailbox))
 
 (define (imap:command:rename connection from to)
-  (imap:command:no-response connection 'RENAME
-			    (adjust-mailbox-name connection from)
-			    (adjust-mailbox-name connection to)))
+  (imap:command:no-response connection 'RENAME from to))
 
 (define (imap:command:copy connection index mailbox)
-  (imap:command:no-response connection 'COPY (+ index 1)
-			    (adjust-mailbox-name connection mailbox)))
+  (imap:command:no-response connection 'COPY (+ index 1) mailbox))
 
 (define (imap:command:append connection mailbox flags time text)
-  (imap:command:no-response connection
-			    'APPEND
-			    (adjust-mailbox-name connection mailbox)
+  (imap:command:no-response connection 'APPEND mailbox
 			    (and (pair? flags) flags)
 			    (imap:universal-time->date-time time)
 			    (cons 'LITERAL text)))
 
 (define (imap:command:search connection . key-plist)
-  (apply imap:command:single-response imap:response:search?
-	 connection 'SEARCH key-plist))
-
-(define (adjust-mailbox-name connection mailbox)
-  (case (imap-connection-server-type connection)
-    ((CYRUS)
-     (if (or (string-ci=? "inbox" mailbox)
-	     (string-prefix-ci? "inbox." mailbox)
-	     (string-prefix-ci? "user." mailbox))
-	 mailbox
-	 (string-append "inbox." mailbox)))
-    (else mailbox)))
+  (apply imap:command:single-response imap:response:search? connection
+	 'SEARCH key-plist))
+
+(define (imap:command:list connection reference pattern)
+  (imap:command:multiple-response imap:response:list? connection
+				  'LIST reference pattern))
 
 (define (imap:command:no-response connection command . arguments)
   (let ((response
diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index b5a8f8d28..9fad354d4 100644
--- 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.33 2000/05/20 19:39:20 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.34 2000/05/22 02:17:47 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -25,25 +25,21 @@
 ;;;; URL
 
 (define-class <rmail-url> (<file-url>))
+(define-url-protocol "rmail" <rmail-url>)
 
-(let ((filter
-       (let ((suffix-filter (file-suffix-filter "rmail")))
-	 (lambda (pathname)
-	   (or (string-ci=? (file-namestring pathname) "rmail")
-	       (suffix-filter string))))))
-  (define-url-protocol "rmail" <rmail-url>
-    (lambda (string)
-      (%make-rmail-url (short-name->pathname string)))
-    (file-url-completer filter)
-    (file-url-completions filter)))
-
-(define (make-rmail-url pathname)
-  (save-url (%make-rmail-url pathname)))
-
-(define %make-rmail-url
+(define make-rmail-url
   (let ((constructor (instance-constructor <rmail-url> '(PATHNAME))))
     (lambda (pathname)
-      (constructor (merge-pathnames pathname)))))
+      (intern-url (constructor (merge-pathnames pathname))))))
+
+(define-method %parse-url-string ((string <string>) (default-url <rmail-url>))
+  (make-rmail-url (merge-pathnames string (file-url-pathname default-url))))
+
+(define-file-url-completers <rmail-url>
+  (let ((type-filter (file-type-filter "rmail")))
+    (lambda (pathname)
+      (or (string-ci=? (file-namestring pathname) "rmail")
+	  (type-filter string)))))
 
 ;;;; Server operations
 
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 734b394e0..1467aac8c 100644
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.77 2000/05/19 21:25:31 cph Exp $
+;;; $Id: imail-top.scm,v 1.78 2000/05/22 02:17:50 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -104,10 +104,10 @@ May be called with an IMAIL folder URL as argument;
  but does not copy any new mail into the folder."
   (lambda ()
     (list (and (command-argument)
-	       (prompt-for-string "Run IMAIL on folder" #f
-				  'DEFAULT-TYPE 'VISIBLE-DEFAULT
-				  'HISTORY 'IMAIL
-				  'HISTORY-INDEX 0))))
+	       (prompt-for-imail-url-string "Run IMAIL on folder" #f
+					    'DEFAULT-TYPE 'VISIBLE-DEFAULT
+					    'HISTORY 'IMAIL
+					    'HISTORY-INDEX 0))))
   (lambda (url-string)
     (let ((folder
 	   (open-folder
@@ -134,36 +134,56 @@ May be called with an IMAIL folder URL as argument;
 					" on host "
 					(imap-url-host url))
 			 receiver))
+
+(define (prompt-for-imail-url-string prompt default . options)
+  (apply prompt-for-completed-string
+	 prompt
+	 default
+	 (lambda (string if-unique if-not-unique if-not-found)
+	   (url-complete-string string imail-get-default-url
+				if-unique if-not-unique if-not-found))
+	 (lambda (string)
+	   (url-string-completions string imail-get-default-url))
+	 (lambda (string) string #t)
+	 options))
 
 (define (imail-default-url)
   (let ((primary-folder (ref-variable imail-primary-folder)))
     (if primary-folder
 	(imail-parse-partial-url primary-folder)
-	(imail-default-imap-url))))
+	(imail-get-default-url "imap"))))
 
 (define (imail-parse-partial-url string)
-  (->url
-   (let ((colon (string-find-next-char string #\:)))
-     (if colon
-	 string
-	 (string-append "imap:" string)))))
-
-(define (imail-default-imap-url)
-  (call-with-values
-      (lambda ()
-	(let ((server (ref-variable imail-default-imap-server)))
-	  (let ((colon (string-find-next-char server #\:)))
-	    (if colon
-		(values (string-head server colon)
-			(or (string->number (string-tail server (+ colon 1)))
-			    (error "Invalid port specification:" server)))
-		(values server 143)))))
-    (lambda (host port)
-      (make-imap-url (or (ref-variable imail-default-user-id)
-			 (current-user-name))
-		     host
-		     port
-		     (ref-variable imail-default-imap-mailbox)))))
+  (parse-url-string string imail-get-default-url))
+
+(define (imail-get-default-url protocol)
+  (let ((do-imap
+	 (lambda ()
+	   (call-with-values
+	       (lambda ()
+		 (let ((server (ref-variable imail-default-imap-server)))
+		   (let ((colon (string-find-next-char server #\:)))
+		     (if colon
+			 (values
+			  (string-head server colon)
+			  (or (string->number (string-tail server (+ colon 1)))
+			      (error "Invalid port specification:" server)))
+			 (values server 143)))))
+	     (lambda (host port)
+	       (make-imap-url (or (ref-variable imail-default-user-id)
+				  (current-user-name))
+			      host
+			      port
+			      (ref-variable imail-default-imap-mailbox)))))))
+    (cond ((not protocol)
+	   (let ((folder (selected-folder #f)))
+	     (if folder
+		 (folder-url folder)
+		 (do-imap))))
+	  ((string-ci=? protocol "imap") (do-imap))
+	  ((string-ci=? protocol "rmail") (make-rmail-url "~/RMAIL"))
+	  ((string-ci=? protocol "umail") (make-umail-url "~/inbox.mail"))
+	  (else (error:bad-range-argument protocol)))))
 
 (define (imail-present-user-alert procedure)
   (call-with-output-to-temporary-buffer " *IMAP alert*"
@@ -408,10 +428,9 @@ With prefix argument N moves forward N messages with these flags."
 			 (lambda (flag)
 			   (message-flagged? message flag))))
 		     (string-append "message with flag"
-				    (if (fix:= 1 (length flags)) "" "s")
+				    (if (= 1 (length flags)) "" "s")
 				    " "
-				    (decorated-string-append "" ", " ""
-							     flags))
+				    (decorated-string-append "" ", " "" flags))
 		     #f))))
 
 (define-command imail-previous-flagged-message
@@ -828,7 +847,11 @@ With prefix argument N, removes FLAG from next N messages,
 
 (define-command imail-input
   "Append messages to this folder from a specified folder."
-  "sInput from folder"
+  (lambda ()
+    (list (prompt-for-imail-url-string "Input from folder" #f
+				       'DEFAULT-TYPE 'INSERTED-DEFAULT
+				       'HISTORY 'IMAIL-INPUT
+				       'HISTORY-INDEX 0)))
   (lambda (url-string)
     (let ((folder (selected-folder)))
       (let ((folder* (open-folder (imail-parse-partial-url url-string)))
@@ -845,10 +868,10 @@ With prefix argument N, removes FLAG from next N messages,
 (define-command imail-output
   "Append this message to a specified folder."
   (lambda ()
-    (list (prompt-for-string "Output to folder" #f
-			     'DEFAULT-TYPE 'INSERTED-DEFAULT
-			     'HISTORY 'IMAIL-OUTPUT
-			     'HISTORY-INDEX 0)
+    (list (prompt-for-imail-url-string "Output to folder" #f
+				       'DEFAULT-TYPE 'INSERTED-DEFAULT
+				       'HISTORY 'IMAIL-OUTPUT
+				       'HISTORY-INDEX 0)
 	  (command-argument)))
   (lambda (url-string argument)
     (let ((delete? (ref-variable imail-delete-after-output)))
@@ -866,13 +889,21 @@ With prefix argument N, removes FLAG from next N messages,
 (define-command imail-create-folder
   "Create a new folder with the specified name.
 An error if signalled if the folder already exists."
-  "sCreate folder"
+  (lambda ()
+    (list (prompt-for-imail-url-string "Create folder" #f
+				       'DEFAULT-TYPE 'INSERTED-DEFAULT
+				       'HISTORY 'IMAIL-CREATE-FOLDER
+				       'HISTORY-INDEX 0)))
   (lambda (url-string)
     (create-folder (imail-parse-partial-url url-string))))
 
 (define-command imail-delete-folder
   "Delete a specified folder."
-  "sDelete folder"
+  (lambda ()
+    (list (prompt-for-imail-url-string "Delete folder" #f
+				       'DEFAULT-TYPE 'INSERTED-DEFAULT
+				       'HISTORY 'IMAIL-DELETE-FOLDER
+				       'HISTORY-INDEX 0)))
   (lambda (url-string)
     (delete-folder (imail-parse-partial-url url-string))))
 
diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 2e712742b..bdba2b2c9 100644
--- 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.27 2000/05/20 03:22:50 cph Exp $
+;;; $Id: imail-umail.scm,v 1.28 2000/05/22 02:17:55 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -25,21 +25,18 @@
 ;;;; URL
 
 (define-class <umail-url> (<file-url>))
+(define-url-protocol "umail" <umail-url>)
 
-(let ((filter (file-suffix-filter "mail")))
-  (define-url-protocol "umail" <umail-url>
-    (lambda (string)
-      (%make-umail-url (short-name->pathname string)))
-    (file-url-completer filter)
-    (file-url-completions filter)))
-
-(define (make-umail-url pathname)
-  (save-url (%make-umail-url pathname)))
-
-(define %make-umail-url
+(define make-umail-url
   (let ((constructor (instance-constructor <umail-url> '(PATHNAME))))
     (lambda (pathname)
-      (constructor (merge-pathnames pathname)))))
+      (intern-url (constructor (merge-pathnames pathname))))))
+
+(define-method %parse-url-string ((string <string>) (default-url <umail-url>))
+  (make-umail-url (merge-pathnames string (file-url-pathname default-url))))
+
+(define-file-url-completers <umail-url>
+  (file-type-filter "mail"))
 
 ;;;; Server operations
 
diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index 5811157d2..ceccaf12e 100644
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,5 +1,5 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.31 2000/05/20 03:23:32 cph Exp $
+$Id: todo.txt,v 1.32 2000/05/22 02:17:58 cph Exp $
 
 Bug fixes
 ---------
@@ -29,9 +29,6 @@ Design changes
 * Repackage the code so that each file now in the core is in a
   separate package.
 
-* Do URL defaulting by merging a partially specified URL with the URL
-  of the selected folder.
-
 * Reimplement UID synchronization.  Take advantage of monotonic UID
   numbers to discover largest prefix range that hasn't changed.
   Binary search can be used which should produce excellent results on
@@ -65,8 +62,6 @@ New features
   basically creates the target, opens the source, and copies all of
   the messages.
 
-* Implement URL completion.
-
 * Write M-x imail-resend.
 
 * Add an indication showing the connection status in the mode line.