From: Chris Hanson Date: Mon, 19 Jun 2000 05:00:53 +0000 (+0000) Subject: Change interface for retrieving message bodies so that the body isn't X-Git-Tag: 20090517-FFI~3491 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5eb0b7bd5977a49f8851bd3f93698414eb420a83;p=mit-scheme.git 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 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 ) 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 '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 )) - (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 )) - (+ (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 - 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 () (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 )) folder - #f) \ No newline at end of file + #f) + +(define-method first-unseen-message-index ((folder )) + folder + 0) + +;;;; Message + +(define-class () + (body define accessor)) + +(define-method write-message-body ((message ) port) + (write-string (file-message-body message) port)) + +(define-method set-message-flags! ((message ) flags) + (%set-message-flags! message flags)) + +(define-method message-length ((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 )) + (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 )) +(define-method mime-message-body-structure ((message )) (imap-message-bodystructure message)) -(define-method message-body ((message )) - (message-mime-body-part message '(TEXT) #t)) +(define-method write-message-body ((message ) port) + (write-mime-message-body-part message '(TEXT) #t port)) -(define-method message-mime-body-part - ((message ) selector cache?) +(define-method write-mime-message-body-part + ((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 ( (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 )) @@ -101,7 +100,7 @@ (define-method make-message-copy ((message ) (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 ( (constructor (header-fields body flags from-line))) - () - (body accessor message-body) + () (from-line define accessor)) (define-method umail-message-from-line ((message )) @@ -86,7 +85,7 @@ (define-method make-message-copy ((message ) (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.