From 5eb0b7bd5977a49f8851bd3f93698414eb420a83 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 19 Jun 2000 05:00:53 +0000
Subject: [PATCH] Change interface for retrieving message bodies so that the
body isn't always returned as a string, but instead is written to a port.
This will allow IMAP message to write their bodies directly to files, which
is especially important for bodies that are too large to fit in memory.
---
v7/src/imail/imail-core.scm | 74 ++++++------------------------------
v7/src/imail/imail-file.scm | 68 +++++++++++++++++++++++++++++++--
v7/src/imail/imail-imap.scm | 16 ++++----
v7/src/imail/imail-rmail.scm | 9 ++---
v7/src/imail/imail-umail.scm | 9 ++---
5 files changed, 92 insertions(+), 84 deletions(-)
diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 866f45b7d..352cd6d4e 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.103 2000/06/18 20:39:34 cph Exp $
+;;; $Id: imail-core.scm,v 1.104 2000/06/19 05:00:47 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
@@ -425,12 +425,10 @@
(if (not (message? message))
(error:wrong-type-argument message "IMAIL message" procedure)))
-(define-generic message-body (message))
-
+(define-generic write-message-body (message port))
(define-generic set-message-flags! (message flags))
-
-(define-method set-message-flags! ((message <message>) flags)
- (%set-message-flags! message flags))
+(define-generic message-internal-time (message))
+(define-generic message-length (message))
(define %set-message-flags!
(let ((modifier (slot-modifier <message> 'FLAGS)))
@@ -460,58 +458,11 @@
(set-message-folder! message #f))
(define (message->string message)
- (string-append (header-fields->string (message-header-fields message))
- "\n"
- (message-body message)))
-
-(define-generic message-internal-time (message))
-(define-method message-internal-time ((message <message>))
- (let loop ((headers (get-all-header-fields message "received")) (winner #f))
- (if (pair? headers)
- (loop (cdr headers)
- (let ((time (received-header-time (car headers))))
- (if (and time (or (not winner) (< time winner)))
- time
- winner)))
- (or winner
- (message-time message)))))
-
-(define (received-header-time header)
- (let ((time
- (ignore-errors
- (lambda ()
- (call-with-values
- (lambda ()
- (rfc822:received-header-components
- (header-field-value header)))
- (lambda (from by via with id for time)
- from by via with id for ;ignored
- time))))))
- (and (not (condition? time))
- time)))
-
-(define (message-time message)
- (let ((date (get-first-header-field-value message "date" #f)))
- (and date
- (let ((t
- (ignore-errors
- (lambda ()
- (string->universal-time
- (rfc822:tokens->string
- (rfc822:strip-comments (rfc822:string->tokens date))))))))
- (and (not (condition? t))
- t)))))
-
-(define-generic message-length (message))
-(define-method message-length ((message <message>))
- (+ (apply +
- (map (lambda (header)
- (+ (string-length (header-field-name header))
- (string-length (header-field-value header))
- 2))
- (message-header-fields message)))
- 1
- (string-length (message-body message))))
+ (with-string-output-port
+ (lambda (port)
+ (write-header-fields (message-header-fields message) port)
+ (newline port)
+ (write-message-body message port))))
;;;; Message Navigation
@@ -525,9 +476,6 @@
message))))))
(define-generic first-unseen-message-index (folder))
-(define-method first-unseen-message-index ((folder <folder>))
- folder
- 0)
(define (first-message folder)
(and (> (folder-length folder) 0)
@@ -817,8 +765,8 @@
;;;; MIME structure
-(define-generic message-mime-body-structure (message))
-(define-generic message-mime-body-part (message selector cache?))
+(define-generic mime-message-body-structure (message))
+(define-generic write-mime-message-body-part (message selector cache? port))
(define-class <mime-body> (<imail-object>)
(parameters define accessor)
diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 779427a14..c589ab946 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.44 2000/06/16 17:54:46 cph Exp $
+;;; $Id: imail-file.scm,v 1.45 2000/06/19 05:00:49 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
@@ -191,7 +191,7 @@
(message-header-fields message)))
(string-search-forward
criteria
- (message-body message))))
+ (file-message-body message))))
(cons index winners)
winners))
(reverse! winners)))))
@@ -271,4 +271,66 @@
(define-method folder-supports-mime? ((folder <file-folder>))
folder
- #f)
\ No newline at end of file
+ #f)
+
+(define-method first-unseen-message-index ((folder <file-folder>))
+ folder
+ 0)
+
+;;;; Message
+
+(define-class <file-message> (<message>)
+ (body define accessor))
+
+(define-method write-message-body ((message <file-message>) port)
+ (write-string (file-message-body message) port))
+
+(define-method set-message-flags! ((message <file-message>) flags)
+ (%set-message-flags! message flags))
+
+(define-method message-length ((message <file-message>))
+ (+ (apply +
+ (map (lambda (header)
+ (+ (string-length (header-field-name header))
+ (string-length (header-field-value header))
+ 2))
+ (message-header-fields message)))
+ 1
+ (string-length (file-message-body message))))
+
+(define-method message-internal-time ((message <message>))
+ (let loop ((headers (get-all-header-fields message "received")) (winner #f))
+ (if (pair? headers)
+ (loop (cdr headers)
+ (let ((time (received-header-time (car headers))))
+ (if (and time (or (not winner) (< time winner)))
+ time
+ winner)))
+ (or winner
+ (message-time message)))))
+
+(define (received-header-time header)
+ (let ((time
+ (ignore-errors
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (rfc822:received-header-components
+ (header-field-value header)))
+ (lambda (from by via with id for time)
+ from by via with id for ;ignored
+ time))))))
+ (and (not (condition? time))
+ time)))
+
+(define (message-time message)
+ (let ((date (get-first-header-field-value message "date" #f)))
+ (and date
+ (let ((t
+ (ignore-errors
+ (lambda ()
+ (string->universal-time
+ (rfc822:tokens->string
+ (rfc822:strip-comments (rfc822:string->tokens date))))))))
+ (and (not (condition? t))
+ t)))))
\ No newline at end of file
diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 6b1be93ff..9ff3ffeef 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.121 2000/06/19 01:49:19 cph Exp $
+;;; $Id: imail-imap.scm,v 1.122 2000/06/19 05:00:50 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
@@ -858,14 +858,14 @@
;;;; MIME support
-(define-method message-mime-body-structure ((message <imap-message>))
+(define-method mime-message-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 write-message-body ((message <imap-message>) port)
+ (write-mime-message-body-part message '(TEXT) #t port))
-(define-method message-mime-body-part
- ((message <imap-message>) selector cache?)
+(define-method write-mime-message-body-part
+ ((message <imap-message>) selector cache? port)
(let ((section
(map (lambda (x)
(if (exact-nonnegative-integer? x)
@@ -877,7 +877,7 @@
(lambda (entry)
(equal? (car entry) section)))))
(if entry
- (cdr entry)
+ (write-string (cdr entry) port)
(let ((part (%imap-message-body-part message section)))
(if (let ((limit (and cache? (imail-ui:body-cache-limit message))))
(if (exact-nonnegative-integer? limit)
@@ -887,7 +887,7 @@
message
(cons (cons section part)
(imap-message-body-parts message))))
- part)))))
+ (write-string part port))))))
(define (%imap-message-body-part message section)
(imap:response:fetch-body-part
diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 2c89a8310..4a1411796 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.40 2000/06/16 17:54:56 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.41 2000/06/19 05:00:51 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
@@ -90,8 +90,7 @@
(define-class (<rmail-message>
(constructor (header-fields body flags
displayed-header-fields)))
- (<message>)
- (body accessor message-body)
+ (<file-message>)
(displayed-header-fields define accessor))
(define-method rmail-message-displayed-header-fields ((message <message>))
@@ -101,7 +100,7 @@
(define-method make-message-copy ((message <message>) (folder <rmail-folder>))
folder
(make-rmail-message (message-header-fields message)
- (message-body message)
+ (file-message-body message)
(list-copy (message-flags message))
(rmail-message-displayed-header-fields message)))
@@ -229,7 +228,7 @@
(newline port)
(write-header-fields (if formatted? displayed-headers headers) port)
(newline port)
- (write-string (message-body message) port)
+ (write-message-body message port)
(fresh-line port)
(write-char rmail-message:end-char port))))
diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 09ff4c0f8..8ff64703a 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.32 2000/06/14 02:15:43 cph Exp $
+;;; $Id: imail-umail.scm,v 1.33 2000/06/19 05:00:53 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
@@ -68,8 +68,7 @@
(define-class (<umail-message>
(constructor (header-fields body flags from-line)))
- (<message>)
- (body accessor message-body)
+ (<file-message>)
(from-line define accessor))
(define-method umail-message-from-line ((message <message>))
@@ -86,7 +85,7 @@
(define-method make-message-copy ((message <message>) (folder <umail-folder>))
folder
(make-umail-message (message-header-fields message)
- (message-body message)
+ (file-message-body message)
(list-copy (message-flags message))
(umail-message-from-line message)))
@@ -188,7 +187,7 @@
(write-string ">" port))
(write-string line port)
(newline port))
- (string->lines (message-body message))))
+ (string->lines (file-message-body message))))
;;;; Detection of unix "from" lines.
--
2.25.1