From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 16 May 2000 01:46:42 +0000 (+0000)
Subject: Rewrite IMAP URL parser to eliminate unused authentication component,
X-Git-Tag: 20090517-FFI~3868
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c8a04f7f9f3329c15200bda8f685cfc1293885ac;p=mit-scheme.git

Rewrite IMAP URL parser to eliminate unused authentication component,
and to clarify the allowed partial forms.
---

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index b257ce3a8..96c07f6fe 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.37 2000/05/15 19:20:50 cph Exp $
+;;; $Id: imail-imap.scm,v 1.38 2000/05/16 01:46:37 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -40,24 +40,28 @@
   (save-url (%make-imap-url user-id host port mailbox)))
 
 (define-url-protocol "imap" <imap-url>
-  (let ((//server/
-	 (optional-parser
-	  (sequence-parser (noise-parser (string-matcher "//"))
-			   imap:parse:server
-			   (noise-parser (string-matcher "/")))))
-	(mbox (optional-parser imap:parse:simple-message)))
-    (lambda (string)
-      (let ((end (string-length string)))
-	(let ((pv1 (//server/ string 0 end)))
-	  (let ((pv2
-		 (or (parse-substring mbox string (car pv1) end)
-		     (error:bad-range-argument string 'STRING->URL))))
-	    (%make-imap-url (parser-token pv1 'USER-ID)
-			    (parser-token pv1 'HOST)
-			    (let ((port (parser-token pv1 'PORT)))
-			      (and port
-				   (string->number port)))
-			    (parser-token pv2 'MAILBOX))))))))
+  (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 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)))
 
 (define-method url-body ((url <imap-url>))
   (string-append
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 63a065cb6..f030780a3 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.30 2000/05/15 17:47:54 cph Exp $
+;;; $Id: imail.pkg,v 1.31 2000/05/16 01:46:30 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -133,11 +133,11 @@
 	  imap:char-set:tag-char
 	  imap:char-set:text-char
 	  imap:match:tag
+	  imap:parse:enc-mailbox
 	  imap:parse:section
-	  imap:parse:server
-	  imap:parse:simple-message
 	  imap:quoted-char?
 	  imap:quoted-special?
+	  imap:server-parser
 	  imap:string-may-be-quoted?
 	  imap:write-literal-string-body
 	  imap:write-literal-string-header
diff --git a/v7/src/imail/imap-syntax.scm b/v7/src/imail/imap-syntax.scm
index 3d42ac800..f16d85ea4 100644
--- a/v7/src/imail/imap-syntax.scm
+++ b/v7/src/imail/imap-syntax.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imap-syntax.scm,v 1.6 2000/04/28 16:14:42 cph Exp $
+;;; $Id: imap-syntax.scm,v 1.7 2000/05/16 01:46:42 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -286,32 +286,37 @@
 		   url:decode-substring
 		   (simple-parser match-decoded keyword)))
 
-(define imap:parse:server
+(define (imap:server-parser allow-auth?)
   (sequence-parser
    (optional-parser
-    (let ((parse-user-id
-	   (url:decoding-parser imap:match:achar+
-				imap:match:astring
-				'USER-ID))
-	  (parse-auth
-	   (sequence-parser
-	    (noise-parser (ci-string-matcher ";auth="))
-	    (alternatives-parser
-	     (simple-parser (string-matcher "*") 'AUTH-TYPE)
-	     (url:decoding-parser imap:match:achar+
-				  imap:match:atom
-				  'AUTH-TYPE)))))
-      (sequence-parser
-       (alternatives-parser
-	(sequence-parser parse-user-id
-			 (optional-parser parse-auth))
-	(sequence-parser (optional-parser parse-user-id)
-			 parse-auth))
-       (noise-parser (string-matcher "@")))))
+    (sequence-parser
+     (let ((parse-user-id
+	    (url:decoding-parser imap:match:achar+
+				 imap:match:astring
+				 'USER-ID)))
+       (if allow-auth?
+	   (let ((parse-auth
+		  (sequence-parser
+		   (noise-parser (ci-string-matcher ";auth="))
+		   (alternatives-parser
+		    (simple-parser (string-matcher "*") 'AUTH-TYPE)
+		    (url:decoding-parser imap:match:achar+
+					 imap:match:atom
+					 'AUTH-TYPE)))))
+	     (alternatives-parser
+	      (sequence-parser parse-user-id
+			       (optional-parser parse-auth))
+	      (sequence-parser (optional-parser parse-user-id)
+			       parse-auth)))
+	   parse-user-id))
+     (noise-parser (string-matcher "@"))))
    (simple-parser (rexp-matcher url:rexp:host) 'HOST)
    (optional-parser
     (noise-parser (string-matcher ":"))
     (simple-parser (rexp-matcher (rexp+ char-set:numeric)) 'PORT))))
+
+(define imap:parse:server
+  (imap:server-parser #t))
 
 (define imap:parse:mailboxlist
   (sequence-parser
@@ -354,12 +359,6 @@
 		    (decoding-parser imap:match:bchar+
 				     url:decode-substring
 				     imap:parse:section))))
-
-(define imap:parse:simple-message
-  (sequence-parser imap:parse:enc-mailbox
-		   (optional-parser
-		    (noise-parser (ci-string-matcher "/;uid="))
-		    (simple-parser imap:match:nz-number 'UID))))
 
 ;;;; Mailbox-name encoding (modified UTF-7)