From d31f57aedc5459284efcc96ba3fe3dc16f2ef0be Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 27 May 2001 05:05:54 +0000
Subject: [PATCH] Cache result of URL-IS-CONTAINER?, to prevent going back to
 network each time it's needed.  This might not actually work, since the
 definition of URL-IS-CONTAINER? specifies that the corresponding mailbox must
 exist.

---
 v7/src/imail/imail-imap.scm | 97 +++++++++++++++++++++++++------------
 1 file changed, 65 insertions(+), 32 deletions(-)

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 3b7af5701..cfebe9509 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.164 2001/05/25 18:16:53 cph Exp $
+;;; $Id: imail-imap.scm,v 1.165 2001/05/27 05:05:54 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -36,9 +36,12 @@
   (mailbox define accessor))
 
 (define-url-protocol "imap" <imap-url>)
-(define-class <imap-folder-url> (<imap-url> <folder-url>))
 (define-class <imap-container-url> (<imap-url> <container-url>))
 
+(define-class <imap-folder-url> (<imap-url> <folder-url>)
+  (is-container? define standard
+		 initial-value 'UNKNOWN))
+
 (define make-imap-url
   (let ((fields '(USER-ID HOST PORT MAILBOX)))
     (let ((make-folder (instance-constructor <imap-folder-url> fields))
@@ -105,11 +108,19 @@
 	 (not (memq '\NOSELECT (imap:response:list-flags response))))))
 
 (define-method url-is-container? ((url <imap-folder-url>))
-  (let ((response (imap-url-info url)))
-    (and response
-	 (not (memq '\NOINFERIORS (imap:response:list-flags response)))
-	 (imap-url-new-mailbox url
-			       (string-append (imap-url-mailbox url) "/")))))
+  (let ((container (imap-folder-url-is-container? url)))
+    (if (eq? container 'UNKNOWN)
+	(let ((response (imap-url-info url)))
+	  (and response
+	       (let ((container
+		      (and (not (memq '\NOINFERIORS
+				      (imap:response:list-flags response)))
+			   (imap-url-new-mailbox
+			    url
+			    (string-append (imap-url-mailbox url) "/")))))
+		 (set-imap-folder-url-is-container?! url container)
+		 container)))
+	container)))
 
 (define (imap-url-info url)
   (let ((responses
@@ -227,8 +238,18 @@
 		      prefix)))))))
 
 (define-method container-url-contents ((url <imap-container-url>))
-  (map (lambda (mailbox) (imap-url-new-mailbox url mailbox))
-       (imap-mailbox-completions (imap-url-mailbox url) url)))
+  (%imap-mailbox-completions (imap-url-mailbox url) url
+    (lambda (mailbox selectable? inferiors? tail)
+      (let ((container
+	     (and inferiors?
+		  (imap-url-new-mailbox url (string-append mailbox "/")))))
+	(cond (selectable?
+	       (let ((url (imap-url-new-mailbox url mailbox)))
+		 (if (eq? (imap-folder-url-is-container? url) 'UNKNOWN)
+		     (set-imap-folder-url-is-container?! url container))
+		 (cons url tail)))
+	      (container (cons container tail))
+	      (else tail))))))
 
 ;;;; Completion
 
@@ -278,32 +299,44 @@
 	       (if-not-unique (string-greatest-common-prefix responses)
 			      (lambda () responses)))
 	      (else (if-unique (car responses)))))))
-
+
 (define (imap-mailbox-completions prefix url)
+  (%imap-mailbox-completions prefix url
+    (lambda (mailbox selectable? inferiors? tail)
+      (cond (selectable? (cons mailbox tail))
+	    (inferiors? (cons (string-append mailbox "/") tail))
+	    (else tail)))))
+
+(define (%imap-mailbox-completions prefix url accumulator)
   (with-open-imap-connection url
     (lambda (connection)
-      (append-map! (lambda (response)
-		     (let ((flags (imap:response:list-flags response))
-			   (delimiter (imap:response:list-delimiter response))
-			   (mailbox
-			    (imap:decode-mailbox-name
-			     (imap:response:list-mailbox response))))
-		       (if delimiter
-			   (let ((mailbox
-				  (string-replace mailbox
-						  (string-ref delimiter 0)
-						  #\/)))
-			     (if (memq '\NOSELECT flags)
-				 (if (memq '\NOINFERIORS flags)
-				     '()
-				     (list (string-append mailbox "/")))
-				 (list mailbox)))
-			   (list mailbox))))
-		   (imap:command:list
-		    connection
-		    ""
-		    (string-append (imap-mailbox/url->server url prefix)
-				   "%"))))))
+      (let loop
+	  ((responses
+	    (imap:command:list
+	     connection
+	     ""
+	     (string-append (imap-mailbox/url->server url prefix) "%")))
+	   (results '()))
+	(if (pair? responses)
+	    (loop (cdr responses)
+		  (let ((flags (imap:response:list-flags (car responses)))
+			(delimiter
+			 (imap:response:list-delimiter (car responses)))
+			(mailbox
+			 (imap:decode-mailbox-name
+			  (imap:response:list-mailbox (car responses)))))
+		    (if delimiter
+			(accumulator (string-replace mailbox
+						     (string-ref delimiter 0)
+						     #\/)
+				     (not (memq '\NOSELECT flags))
+				     (not (memq '\NOINFERIORS flags))
+				     results)
+			(accumulator mailbox
+				     (not (memq '\NOSELECT flags))
+				     #f
+				     results))))
+	    (reverse! results))))))
 
 ;;;; URL->server delimiter conversion
 
-- 
2.25.1