From 8bb0e1e4270ff8d23aa4c91104d26193025481fd Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 5 Jun 2000 20:56:52 +0000 Subject: [PATCH] Unify handling of body cache. Add editor variable to control the caching. --- v7/src/imail/imail-core.scm | 13 +++----- v7/src/imail/imail-imap.scm | 64 ++++++++++++++++-------------------- v7/src/imail/imail-rmail.scm | 3 +- v7/src/imail/imail-top.scm | 16 ++++++++- v7/src/imail/imail-umail.scm | 3 +- v7/src/imail/imail.pkg | 3 +- 6 files changed, 54 insertions(+), 48 deletions(-) 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 ( (constructor (header-fields body flags))) - () +(define-class () (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 ) 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 () 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-bodystructure message)) +(define-method message-body ((message )) + (message-mime-body-part message '(TEXT) #t)) + (define-method message-mime-body-part ((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 'HEADER-FIELDS)) -(define %set-message-body! - (slot-modifier 'BODY)) - (define %message-flags-initialized? (slot-initpred '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))) () + (body accessor message-body) (displayed-header-fields define accessor)) (define-method rmail-message-displayed-header-fields ((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 ( (constructor (header-fields body flags from-line))) () + (body accessor message-body) (from-line define accessor)) (define-method umail-message-from-line ((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 -- 2.25.1