Add new folder operation, PRELOAD-FOLDER-OUTLINES, which is a hint to

the folder implementation that the front end is about to request
header and length information for all messages in the folder.  This
allows the folder to choose a more-optimal download strategy.  The
operation is invoked by the folder-summary code.

Ad-hoc testing indicates that this has a qualitative effect on
performance for folders containing about 100 or more messages.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 94e06cf889102196907ebf62793c7c9b63c45945..d88744327ead766d2a53e77f7fd72f48210b32dd 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.112 2000/06/30 17:21:24 cph Exp $
+;;; $Id: imail-core.scm,v 1.113 2000/08/05 01:53:36 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -360,7 +360,7 @@
   (%get-message folder index))
 
 (define-generic %get-message (folder index))
-\f
+
 ;; -------------------------------------------------------------------
 ;; Remove all messages in FOLDER that are marked for deletion.
 ;; Unspecified result.
@@ -372,7 +372,7 @@
 ;; may be a string.  Returns a list of messages.
 
 (define-generic search-folder (folder criteria))
-
+\f
 ;; -------------------------------------------------------------------
 ;; Compare FOLDER's cache with the persistent folder and return a
 ;; symbol indicating whether they are synchronized, as follows:
@@ -417,6 +417,15 @@
 ;; Return #T if FOLDER supports MIME parsing.
 
 (define-generic folder-supports-mime? (folder))
+
+;; -------------------------------------------------------------------
+;; Preload outline information about each message in the folder.
+;; Normally used prior to generating a folder summary, to accelerate
+;; the downloading of this information from the server.  This
+;; operation need not be implemented, as it is just a performance
+;; enhancement.
+
+(define-generic preload-folder-outlines (folder))
 \f
 ;;;; Message type
 

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index c98450915bf872729edbc7aedf723117c82b6654..2a70a1057e95782803edd7a662aa819b6c767615 100644 (file)
--- 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.56 2000/07/05 20:49:36 cph Exp $
+;;; $Id: imail-file.scm,v 1.57 2000/08/05 01:53:41 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -308,6 +308,10 @@
   folder
   #f)
 
+(define-method preload-folder-outlines ((folder <file-folder>))
+  folder
+  unspecific)
+
 (define-method first-unseen-message-index ((folder <file-folder>))
   folder
   0)

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 085ae6c51cd7b05974d6959acc61eb99b1e7f0ca..7cbe26c53d7f49d2f0da80478ff37c7b622de5cd 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.142 2000/08/02 13:15:27 cph Exp $
+;;; $Id: imail-imap.scm,v 1.143 2000/08/05 01:53:44 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -934,6 +934,54 @@
               (guarantee-slot-initialized message initpred "body structure"
                                           '(BODYSTRUCTURE)))))
 \f
+(define-method preload-folder-outlines ((folder <imap-folder>))
+  (guarantee-imap-folder-open folder)
+  (let ((messages
+        (messages-satisfying folder
+          (lambda (message)
+            (not (and (imap-message-header-fields-initialized? message)
+                      (imap-message-length-initialized? message)))))))
+    (if (pair? messages)
+       ((imail-ui:message-wrapper "Reading message headers")
+        (lambda ()
+          (imap:command:fetch-set (imap-folder-connection folder)
+                                  (message-list->set messages)
+                                  '(RFC822.HEADER RFC822.SIZE)))))))
+       
+
+(define imap-message-header-fields-initialized?
+  (slot-initpred <imap-message> 'HEADER-FIELDS))
+
+(define imap-message-length-initialized?
+  (slot-initpred <imap-message> 'LENGTH))
+
+(define (messages-satisfying folder predicate)
+  (let ((n (folder-length folder)))
+    (let loop ((i 0) (messages '()))
+      (if (< i n)
+         (loop (+ i 1)
+               (let ((message (get-message folder i)))
+                 (if (predicate message)
+                     (cons message messages)
+                     messages)))
+         (reverse! messages)))))
+
+(define (message-list->set messages)
+  (let loop ((indexes (map message-index messages)) (groups '()))
+    (if (pair? indexes)
+       (let ((start (car indexes)))
+         (let parse-group ((this start) (rest (cdr indexes)))
+           (if (and (pair? rest) (= (car rest) (+ this 1)))
+               (parse-group (car rest) (cdr rest))
+               (loop rest
+                     (cons (if (= start this)
+                               (number->string (+ start 1))
+                               (string-append (number->string (+ start 1))
+                                              ":"
+                                              (number->string (+ this 1))))
+                           groups)))))
+       (decorated-string-append "" "," "" (reverse! groups)))))
+\f
 ;;;; MIME support
 
 (define-method mime-message-body-structure ((message <imap-message>))
@@ -1332,13 +1380,15 @@
                                uid items))
 
 (define (imap:command:fetch-range connection start end items)
-  (imap:command:multiple-response
-   imap:response:fetch? connection
-   'FETCH
-   `',(string-append (number->string (+ start 1))
-                    ":"
-                    (if end (number->string end) "*"))
-   items))
+  (imap:command:fetch-set connection
+                         (string-append (number->string (+ start 1))
+                                        ":"
+                                        (if end (number->string end) "*"))
+                         items))
+
+(define (imap:command:fetch-set connection set items)
+  (imap:command:multiple-response imap:response:fetch? connection
+                                 'FETCH `',set items))
 \f
 (define (imap:command:uid-store-flags connection uid flags)
   (imap:command:no-response connection 'UID 'STORE uid 'FLAGS flags))

diff --git a/v7/src/imail/imail-summary.scm b/v7/src/imail/imail-summary.scm
index a2469aa06b402b625238be2767d3c8e0a3ea10d4..af73b0db81d158bf0085ab039653182a45c10da2 100644 (file)
--- a/v7/src/imail/imail-summary.scm
+++ b/v7/src/imail/imail-summary.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-summary.scm,v 1.24 2000/07/28 15:25:50 cph Exp $
+;;; $Id: imail-summary.scm,v 1.25 2000/08/05 01:53:54 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -147,6 +147,7 @@ SUBJECT is a string of regexps separated by commas."
          (if (pair? windows)
              (select-window (car windows))
              (select-buffer buffer))))
+    (preload-folder-outlines folder)
     (rebuild-imail-summary-buffer buffer)))
 
 (define (imail-summary-detach buffer)