From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 22 May 2000 03:01:30 +0000 (+0000)
Subject: Restructure the URL completion code to clean it up a bit.  Change the
X-Git-Tag: 20090517-FFI~3764
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c6d3aeb9784aaffcc1ccc86f2306fb6f6c10e576;p=mit-scheme.git

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 49fd53254..10db2a748 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.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)))))))
 
 ;;;; Server operations
 
diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 4de06cc01..f97bc8b60 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.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))))))
 
 (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 9fad354d4..9c6014912 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.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 bdba2b2c9..fd0d5cb92 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.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 d6aabe5e5..98196dd43 100644
--- 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))
 
-;;;; 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)))))
-
 ;;;; Filename Completion
 
 (define (pathname-complete-string pathname filter