Integrate MIME decoding into reading of MIME body parts.

Large attachments are now read directly into files.

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index e4127765efccf4cda0aac495b908b41b3dbc4307..1e46edbce9f1f9a4eceefc41fe3605dcc3335abd 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.135 2000/06/30 18:31:40 cph Exp $
+;;; $Id: imail-imap.scm,v 1.136 2000/06/30 19:05:47 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -942,7 +942,9 @@
                      (imap-message-body-parts message)))
               (write-string part port)))
            (else
-            (write-string (%imap-message-body-part message section) port))))))
+            (imap:bind-fetch-body-part-port port
+              (lambda ()
+                (%imap-message-body-part message section))))))))
 
 (define (%imap-message-body-part message section)
   (imap:response:fetch-body-part

diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 781f51b0209b92f782b7ec15d86367827345f6c3..077b58a54478ec8995d1776d7ab3b80da87e13c9 100644 (file)
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.69 2000/06/27 17:25:48 cph Exp $
+;;; $Id: imail.pkg,v 1.70 2000/06/30 19:05:46 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -136,6 +136,7 @@
          imap-transcript-write-char
          imap-transcript-write-string
          imap-transcript-write-substring
+         imap:bind-fetch-body-part-port
          imap:read-literal-progress-hook
          imap:read-server-response
          imap:response-code:alert?

diff --git a/v7/src/imail/imap-response.scm b/v7/src/imail/imap-response.scm
index 115d302c46f4ef016a553f4f27525620b2041772..81ae62d6b8a74073c9e72b7fec8dffb62ca7c591 100644 (file)
--- a/v7/src/imail/imap-response.scm
+++ b/v7/src/imail/imap-response.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imap-response.scm,v 1.35 2000/06/15 20:40:27 cph Exp $
+;;; $Id: imap-response.scm,v 1.36 2000/06/30 19:05:49 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -186,7 +186,10 @@
                               (discard-known-char #\> port)
                               (discard-known-char #\space port)
                               n)))))
-               (list x section origin (read-nstring port))))
+               (list x section origin
+                     (if *fetch-body-part-port*
+                         (read-nstring-to-port port *fetch-body-part-port*)
+                         (read-nstring port)))))
            (begin
              (discard-known-char #\space port)
              (list x
@@ -206,6 +209,12 @@
                      (else
                       (error "Illegal fetch keyword:" x))))))))))
 
+(define (imap:bind-fetch-body-part-port port thunk)
+  (fluid-let ((*fetch-body-part-port* port))
+    (thunk)))
+
+(define *fetch-body-part-port* #f)
+
 (define (parse-section string)
   (let ((pv (parse-string imap:parse:section string)))
     (if (not pv)
@@ -248,46 +257,56 @@
          ((char=? #\{ char) (read-literal port))
          (else (error "Illegal astring syntax:" char)))))
 
-(define (read-nstring port)
-  (let ((char (peek-char-no-eof port)))
-    (cond ((char=? #\" char) (read-quoted port))
-         ((char=? #\{ char) (read-literal port))
+(define (read-nstring input)
+  (let ((output (make-accumulator-output-port)))
+    (and (read-nstring-to-port input output)
+        (get-output-from-accumulator output))))
+
+(define (read-nstring-to-port input output)
+  (let ((char (peek-char-no-eof input)))
+    (cond ((char=? #\" char)
+          (read-quoted-to-port input output)
+          "")
+         ((char=? #\{ char)
+          (read-literal-to-port input output)
+          "")
          ((imap:atom-char? char)
-          (let ((atom (read-atom port)))
+          (let ((atom (read-atom input)))
             (if (string-ci=? "NIL" atom)
                 #f
                 (error "Illegal nstring:" atom))))
          (else (error "Illegal astring syntax:" char)))))
 
-(define (read-quoted port)
-  (discard-known-char #\" port)
-  (let ((port* (make-accumulator-output-port))
-       (lose (lambda () (error "Malformed quoted string."))))
+(define (read-quoted input)
+  (with-string-output-port
+    (lambda (output)
+      (read-quoted-to-port input output))))
+
+(define (read-quoted-to-port input output)
+  (discard-known-char #\" input)
+  (let ((lose (lambda () (error "Malformed quoted string."))))
     (let loop ()
-      (let ((char (read-char-no-eof port)))
+      (let ((char (read-char-no-eof input)))
        (cond ((imap:quoted-char? char)
-              (write-char char port*)
+              (write-char char output)
               (loop))
-             ((char=? #\" char)
-              (get-output-from-accumulator port*))
              ((char=? #\\ char)
               (let ((char (read-char-no-eof char)))
                 (if (imap:quoted-special? char)
                     (begin
-                      (write-char char port*)
+                      (write-char char output)
                       (loop))
                     (lose))))
-             (else (lose)))))))
+             ((not (char=? #\" char))
+              (lose)))))))
 \f
-(define (read-literal port)
-  (let ((output (make-accumulator-output-port)))
-    (read-literal-internal port
-      (lambda (string start end)
-       (write-substring string start end output)))
-    (get-output-from-accumulator output)))
+(define (read-literal input)
+  (with-string-output-port
+    (lambda (output)
+      (read-literal-to-port input output))))
 
-(define (read-literal-internal port handler)
-  (let ((n (read-literal-length port))
+(define (read-literal-to-port input output)
+  (let ((n (read-literal-length input))
        (b1 (make-string 4096))
        (b2 (make-string 4096)))
     (let loop ((i 0))
@@ -296,15 +315,15 @@
              (lambda ()
                (let ((n-to-read (fix:- n i)))
                  (if (fix:<= n-to-read 4096)
-                     (read-and-translate port n-to-read #t b1 b2)
-                     (read-and-translate port 4096 #f b1 b2))))
+                     (read-and-translate input n-to-read #t b1 b2)
+                     (read-and-translate input 4096 #f b1 b2))))
            (lambda (n-read n-written)
              (if (fix:= 0 n-read)
-                 (error "Premature EOF:" port))
+                 (error "Premature EOF:" input))
              (let ((i (fix:+ i n-read)))
                (if (and *read-literal-progress-hook* (fix:<= i n))
                    (*read-literal-progress-hook* i n))
-               (handler b2 0 n-written)
+               (write-substring b2 0 n-written output)
                (loop i))))))))
 
 (define (read-literal-length port)

diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index 86733b98afa05786de0203a552073d4859907fc1..d0abeb3365fdbdd444981597a12e036c4aa31651 100644 (file)
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,5 +1,5 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.106 2000/06/30 03:16:15 cph Exp $
+$Id: todo.txt,v 1.107 2000/06/30 19:05:50 cph Exp $
 
 Bug fixes
 ---------
@@ -47,11 +47,6 @@ New features
 Design changes
 --------------
 
-* Integrate MIME decoding into reading of MIME body parts by
-  fluid-binding the decoder as a handler for the MIME response reader.
-  Use this same mechanism to read MIME attachments directly into
-  files.
-
 * Move pathname-completion code into the runtime system.
 
 * Repackage the code so that each file now in the core is in a