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.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 866f45b7d27253f2e6f872e5c3050ccb6515371a..352cd6d4efc056995a2f4979bfd78ca9ac6513f1 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.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)))
-\f
-(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))))
 \f
 ;;;; 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 @@
 \f
 ;;;; 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 779427a1433363fe898dc1bdb755115c321f9a6d..c589ab946d9e2d10298ea43794c06cdfa9688777 100644 (file)
--- 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)
+\f
+;;;; 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 6b1be93ff16170cb1b53183c7ea5e98bf5825a15..9ff3ffeef3eb9918c80de6545f3fbca776d46292 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.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 @@
 \f
 ;;;; 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 2c89a83101cf85ebc3d333405464a762736613fd..4a1411796593086f0575ff124cd0722853d29361 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.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)))
 \f
@@ -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 09ff4c0f89c54517a04a78dd5498bceeeeeca988..8ff64703af5b6582bd8804bff2a0700047fceab8 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.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))))
 \f
 ;;;; Detection of unix "from" lines.