Unify handling of body cache. Add editor variable to control the

caching.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index ec2d893cb3ae483a6f9259b89d347dcf5611c344..59a66b955f31cdbb0213ed8f34fde9e5ae56d62e 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.97 2000/06/05 17:50:53 cph Exp $
+;;; $Id: imail-core.scm,v 1.98 2000/06/05 20:56:46 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -396,10 +396,8 @@
 \f
 ;;;; Message type
 
-(define-class (<message> (constructor (header-fields body flags)))
-    (<imail-object>)
+(define-class <message> (<imail-object>)
   (header-fields define accessor)
-  (body define accessor)
   (flags define accessor)
   (folder define standard
          initial-value #f)
@@ -418,6 +416,8 @@
   (if (not (message? message))
       (error:wrong-type-argument message "IMAIL message" procedure)))
 
+(define-generic message-body (message))
+
 (define-generic set-message-flags! (message flags))
 
 (define-method set-message-flags! ((message <message>) flags)
@@ -808,11 +808,6 @@
 ;;;; MIME structure
 
 (define-generic message-mime-body-structure (message))
-
-;; Cache is either a boolean or an exact nonnegative integer.
-;; #F means don't cache.
-;; #T means cache unconditionally.
-;; integer means cache if less than this length.
 (define-generic message-mime-body-part (message selector cache?))
 
 (define-class <mime-body> (<imail-object>)

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index c9a60be76fc1df7f8e63eb054e495aa8c3becdd7..2aca4495b018096073f968698802d4a45a9ed860 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.110 2000/06/05 18:29:16 cph Exp $
+;;; $Id: imail-imap.scm,v 1.111 2000/06/05 20:56:48 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -743,9 +743,6 @@
   (guarantee-slot-initialized message initpred "headers"
                              '(FLAGS RFC822.SIZE RFC822.HEADER)))
 
-(define (guarantee-body-initialized message initpred)
-  (guarantee-slot-initialized message initpred "body" '(RFC822.TEXT)))
-
 (define (guarantee-slot-initialized message initpred noun keywords)
   (if (not (initpred message))
       (with-imap-message-open message
@@ -772,7 +769,6 @@
             (call-next-method message))))))
   (reflector message-header-fields 'HEADER-FIELDS
             guarantee-headers-initialized)
-  (reflector message-body 'BODY guarantee-body-initialized)
   (reflector message-flags 'FLAGS guarantee-headers-initialized))
 
 (let ((reflector
@@ -798,36 +794,40 @@
 (define-method message-mime-body-structure ((message <imap-message>))
   (imap-message-bodystructure message))
 
+(define-method message-body ((message <imap-message>))
+  (message-mime-body-part message '(TEXT) #t))
+
 (define-method message-mime-body-part
     ((message <imap-message>) selector cache?)
-  (if (equal? selector '(TEXT))
-      (message-body message)
-      (let ((section
-            (map (lambda (x)
-                   (if (exact-nonnegative-integer? x)
-                       (+ x 1)
-                       x))
-                 selector)))
-       (let ((entry
-              (list-search-positive (imap-message-body-parts message)
-                (lambda (entry)
-                  (equal? (car entry) section)))))
-         (if entry
-             (cdr entry)
-             (let ((part (%imap-message-body-part message section)))
-               (if (and cache?
-                        (or (eq? cache? #t)
-                            (< (string-length part) cache?)))
-                   (set-imap-message-body-parts!
-                    message
-                    (cons (cons section part)
-                          (imap-message-body-parts message))))
-               part))))))
+  (let ((section
+        (map (lambda (x)
+               (if (exact-nonnegative-integer? x)
+                   (+ x 1)
+                   x))
+             selector)))
+    (let ((entry
+          (list-search-positive (imap-message-body-parts message)
+            (lambda (entry)
+              (equal? (car entry) section)))))
+      (if entry
+         (cdr entry)
+         (let ((part (%imap-message-body-part message section)))
+           (if (let ((limit (and cache? (imail-ui:body-cache-limit message))))
+                 (if (exact-nonnegative-integer? limit)
+                     (< (string-length part) limit)
+                     limit))
+               (set-imap-message-body-parts!
+                message
+                (cons (cons section part)
+                      (imap-message-body-parts message))))
+           part)))))
 
 (define (%imap-message-body-part message section)
   (imap:response:fetch-body-part
    (let ((suffix 
-         (string-append " body part for message "
+         (string-append " body"
+                        (if (equal? section '(TEXT)) "" " part")
+                        " for message "
                         (number->string (+ (message-index message) 1)))))
      ((imail-message-wrapper "Reading" suffix)
       (lambda ()
@@ -1561,9 +1561,6 @@
     ((RFC822.SIZE)
      (%set-imap-message-length! message datum)
      #t)
-    ((RFC822.TEXT)
-     (%set-message-body! message datum)
-     #t)
     ((UID)
      (%set-imap-message-uid! message datum)
      #t)
@@ -1577,9 +1574,6 @@
 (define %set-message-header-fields!
   (slot-modifier <imap-message> 'HEADER-FIELDS))
 
-(define %set-message-body!
-  (slot-modifier <imap-message> 'BODY))
-
 (define %message-flags-initialized?
   (slot-initpred <imap-message> 'FLAGS))
 

diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 99f122b545367663012c04633dfe1222f6fe8e5c..7d603146f23c9fad678b9a0c31e4b55e81e197e4 100644 (file)
--- a/v7/src/imail/imail-rmail.scm
+++ b/v7/src/imail/imail-rmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-rmail.scm,v 1.37 2000/05/23 20:19:05 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.38 2000/06/05 20:56:49 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -86,6 +86,7 @@
               (constructor (header-fields body flags
                                           displayed-header-fields)))
     (<message>)
+  (body accessor message-body)
   (displayed-header-fields define accessor))
 
 (define-method rmail-message-displayed-header-fields ((message <message>))

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index fa614843e533835ed45865750e0ce11742dd33c3..e505237f25a496beb9cd5c81592a7a6c388f12a6 100644 (file)
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.130 2000/06/05 20:04:40 cph Exp $
+;;; $Id: imail-top.scm,v 1.131 2000/06/05 20:56:50 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -80,6 +80,13 @@ SHOW-MESSAGES        Pop up window with messages to be expunged."
   "True means prepend subject with Re: in replies."
   #f
   boolean?)
+
+(define-variable imail-body-cache-limit
+  "Size limit for caching of message bodies.
+Message bodies (or inline MIME message parts) less than this size are cached.
+This variable can also be #T or #F meaning cache/don't cache unconditionally."
+  65536
+  (lambda (x) (or (boolean? x) (exact-nonnegative-integer? x))))
 \f
 (define-variable imail-primary-folder
   "URL for the primary folder that you read your mail from."
@@ -298,6 +305,12 @@ regardless of the folder type."
 
 (define imail-ui:prompt-for-yes-or-no?
   prompt-for-yes-or-no?)
+
+(define (imail-ui:body-cache-limit message)
+  (ref-variable imail-body-cache-limit
+               (let ((folder (message-folder message)))
+                 (and folder
+                      (imail-folder->buffer folder #f)))))
 \f
 (define (imail-call-with-pass-phrase url receiver)
   (let ((key (url-pass-phrase-key url))
@@ -436,6 +449,7 @@ variable's documentation (using \\[describe-variable]) for details:
 
     imail-auto-wrap
     imail-auto-wrap-mime-encoded
+    imail-body-cache-limit
     imail-default-dont-reply-to-names
     imail-default-imap-mailbox
     imail-default-imap-server

diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 19ee2470481b953c9b5391fd219506367dcf6f7e..f61b5a47f7a4eb1ca51720e2c085c3a900116dca 100644 (file)
--- a/v7/src/imail/imail-umail.scm
+++ b/v7/src/imail/imail-umail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-umail.scm,v 1.30 2000/05/23 20:19:08 cph Exp $
+;;; $Id: imail-umail.scm,v 1.31 2000/06/05 20:56:52 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -64,6 +64,7 @@
 (define-class (<umail-message>
               (constructor (header-fields body flags from-line)))
     (<message>)
+  (body accessor message-body)
   (from-line define accessor))
 
 (define-method umail-message-from-line ((message <message>))

diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 79b8291a8341c7f76d9ebf0a668bdb2a89b2cdd6..8eed5d22b90a8d5678fee9ce03880235feae0c1e 100644 (file)
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.46 2000/06/05 20:04:39 cph Exp $
+;;; $Id: imail.pkg,v 1.47 2000/06/05 20:56:45 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -261,6 +261,7 @@
          edwin-mode$imail-summary
          edwin-variable$imail-auto-wrap
          edwin-variable$imail-auto-wrap-mime-encoded
+         edwin-variable$imail-body-cache-limit
          edwin-variable$imail-default-dont-reply-to-names
          edwin-variable$imail-default-imap-mailbox
          edwin-variable$imail-default-imap-server