From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 5 Jun 2000 20:56:52 +0000 (+0000)
Subject: Unify handling of body cache.  Add editor variable to control the
X-Git-Tag: 20090517-FFI~3601
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8bb0e1e4270ff8d23aa4c91104d26193025481fd;p=mit-scheme.git

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 ec2d893cb..59a66b955 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.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 @@
 
 ;;;; 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 c9a60be76..2aca4495b 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.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 99f122b54..7d603146f 100644
--- 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 fa614843e..e505237f2 100644
--- 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))))
 
 (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)))))
 
 (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 19ee24704..f61b5a47f 100644
--- 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 79b8291a8..8eed5d22b 100644
--- 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