From 0f3ef1e96e2706b29b5a44f7de802de2010022fe Mon Sep 17 00:00:00 2001 From: "Taylor R. Campbell" Date: Wed, 27 Aug 2008 14:22:09 +0000 Subject: [PATCH] Don't cache message flags on disk. Do meter the progress of caching folder contents, so that IMAIL does not appear to be hung during the long sequence of lstat(2)s and body structure traversals if the cache has many items already in it. Also report a message when connecting to the IMAP server. --- v7/src/imail/imail-imap.scm | 86 ++++++++++++++++++++++--------------- 1 file changed, 52 insertions(+), 34 deletions(-) diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index e8907d03f..7ce923e4b 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.226 2008/08/25 01:29:02 riastradh Exp $ +$Id: imail-imap.scm,v 1.227 2008/08/27 14:22:09 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -609,8 +609,10 @@ USA. #f (let ((url (imap-connection-url connection))) (let ((port - (open-tcp-stream-socket (imap-url-host url) - (or (imap-url-port url) "imap2")))) + ((imail-ui:message-wrapper "Connecting to " (imap-url-host url)) + (lambda () + (open-tcp-stream-socket (imap-url-host url) + (or (imap-url-port url) "imap2")))))) (port/set-line-ending port 'NEWLINE) (let ((response (imap:catch-no-response #f @@ -1012,7 +1014,7 @@ USA. (lambda () (imap:command:fetch-range (imap-folder-connection folder) - 0 #f '(UID))))))) + 0 #f '(UID FLAGS))))))) (let ((v* (imap-folder-messages folder)) (n* (folder-length folder))) (let loop ((i 0) (i* 0)) @@ -1198,32 +1200,43 @@ USA. ;;;; Preloading Folder Outlines & Caching Folder Contents -(define outline-keywords +;;; Keywords for summary buffers' message outlines. + +(define imap-outline-keywords '(FLAGS INTERNALDATE RFC822.HEADER RFC822.SIZE)) -(define-method preload-folder-outlines ((folder )) - (fill-imap-message-cache folder outline-keywords)) +;;; Keywords for displaying message content. -(define content-keywords +(define imap-content-keywords ;; What other keywords would be useful here? - (append '(BODYSTRUCTURE) outline-keywords)) + (append '(BODYSTRUCTURE) imap-outline-keywords)) + +;;; Keywords that are not to be written into the disk cache. + +(define imap-ephemeral-keywords + '(FLAGS)) + +(define-method preload-folder-outlines ((folder )) + (fill-imap-message-cache folder imap-outline-keywords)) (define-method cache-folder-contents ((folder ) walk-mime-body) - (fill-imap-message-cache folder content-keywords) - ((imail-ui:message-wrapper "Caching folder contents") - (lambda () - (for-each-message folder - (lambda (index message) - index ;ignore - (cond ((imap-message-bodystructure message) - => (lambda (body-structure) - (walk-mime-body message body-structure - (lambda (selector) - (fetch-message-body-part-to-cache - message - (mime-selector->imap-section selector)))))) - (else - (fetch-message-body-part-to-cache message '(TEXT))))))))) + (fill-imap-message-cache folder imap-content-keywords) + (let ((length (folder-length folder))) + ((imail-ui:message-wrapper "Caching folder contents") + (lambda () + (for-each-message folder + (lambda (index message) + (if (zero? (remainder index 10)) + (imail-ui:progress-meter index length)) + (cond ((imap-message-bodystructure message) + => (lambda (body-structure) + (walk-mime-body message body-structure + (lambda (selector) + (fetch-message-body-part-to-cache + message + (mime-selector->imap-section selector)))))) + (else + (fetch-message-body-part-to-cache message '(TEXT)))))))))) (define (for-each-message folder procedure) (let ((n (folder-length folder))) @@ -1290,6 +1303,7 @@ USA. (define (imap-message-keyword-cached? message keyword) (let ((cached-keywords (imap-message-cached-keywords message))) (or (memq keyword cached-keywords) + (memq keyword imap-ephemeral-keywords) (and (file-exists? (message-item-pathname message keyword)) (begin (set-imap-message-cached-keywords! @@ -1613,21 +1627,24 @@ USA. #f))) (define (fetch-message-items message keywords suffix) - (if (equal? keywords '(FLAGS)) + (if (lset= eq? keywords imap-ephemeral-keywords) (fetch-message-items-1 message keywords suffix) (with-folder-locked (message-folder message) (lambda () (let ((alist (map (lambda (keyword) (cons keyword - (let ((pathname - (message-item-pathname message keyword))) - (if (file-exists? pathname) - (list - (read-cached-message-item message - keyword - pathname)) - '())))) + (if (memq keyword imap-ephemeral-keywords) + '() + (let ((pathname + (message-item-pathname message + keyword))) + (if (file-exists? pathname) + (list + (read-cached-message-item message + keyword + pathname)) + '()))))) keywords))) (let ((uncached (list-transform-positive alist @@ -1649,7 +1666,8 @@ USA. (define (cache-fetch-response message response keyword-predicate save-item) (for-each (lambda (keyword) - (if (keyword-predicate keyword) + (if (and (not (memq keyword imap-ephemeral-keywords)) + (keyword-predicate keyword)) (let ((item (imap:response:fetch-attribute response keyword)) (pathname (message-item-pathname message keyword)) (temporary-directory -- 2.25.1