From: Chris Hanson Date: Sat, 5 Aug 2000 01:53:54 +0000 (+0000) Subject: Add new folder operation, PRELOAD-FOLDER-OUTLINES, which is a hint to X-Git-Tag: 20090517-FFI~3307 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=db062b7bb59a9dadabf5d03de162dceae1f046ff;p=mit-scheme.git 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 94e06cf88..d88744327 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.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)) - + ;; ------------------------------------------------------------------- ;; 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)) - + ;; ------------------------------------------------------------------- ;; 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)) ;;;; Message type diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index c98450915..2a70a1057 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.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 )) + folder + unspecific) + (define-method first-unseen-message-index ((folder )) folder 0) diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index 085ae6c51..7cbe26c53 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.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))))) +(define-method preload-folder-outlines ((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 'HEADER-FIELDS)) + +(define imap-message-length-initialized? + (slot-initpred '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))))) + ;;;; MIME support (define-method mime-message-body-structure ((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)) (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 a2469aa06..af73b0db8 100644 --- 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)