Show alternative forms as attachments in MIME multipart/alternative.

Don't show text messages with unknown encodings.

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index fecdff08b47e92a6599283b489812cc478094b0d..c1601f1cb34467bf3471b282b50f931db490e622 100644 (file)
--- 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.139 2000/06/08 04:16:07 cph Exp $
+;;; $Id: imail-top.scm,v 1.140 2000/06/08 17:16:26 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -1044,23 +1044,23 @@ With prefix argument N moves backward N messages with these flags."
 (define-method insert-mime-message-part
     (message (body <mime-body-multipart>) enclosure selector mark)
   enclosure
-  (let ((parts (mime-body-multipart-parts body)))
-    (if (eq? (mime-body-subtype body) 'ALTERNATIVE)
-       (insert-mime-message-part message (car parts) body `(,@selector 0)
-                                 mark)
-       (let ((boundary (mime-body-parameter body 'BOUNDARY "----------")))
-         (do ((parts parts (cdr parts))
-              (i 0 (fix:+ i 1)))
-             ((null? parts))
-           (if (fix:> i 0)
-               (begin
-                 (insert-newline mark)
-                 (insert-string "--" mark)
-                 (insert-string boundary mark)
-                 (insert-newline mark)
-                 (insert-newline mark)))
-           (insert-mime-message-part message (car parts) body `(,@selector ,i)
-                                     mark))))))
+  (let ((boundary (mime-body-parameter body 'BOUNDARY "----------")))
+    (do ((parts (mime-body-multipart-parts body) (cdr parts))
+        (i 0 (fix:+ i 1)))
+       ((null? parts))
+      (if (fix:> i 0)
+         (begin
+           (insert-newline mark)
+           (insert-string "--" mark)
+           (insert-string boundary mark)
+           (insert-newline mark)
+           (insert-newline mark)))
+      (let ((part (car parts))
+           (selector `(,@selector ,i)))
+       (if (and (fix:> i 0)
+                (eq? (mime-body-subtype body) 'ALTERNATIVE))
+           (insert-mime-message-attachment 'ALTERNATIVE part selector mark)
+           (insert-mime-message-part message part body selector mark))))))
 \f
 (define-method insert-mime-message-part
     (message (body <mime-body-message>) enclosure selector mark)
@@ -1081,48 +1081,55 @@ With prefix argument N moves backward N messages with these flags."
 
 (define-method insert-mime-message-part
     (message (body <mime-body-text>) enclosure selector mark)
-  (if (re-string-match (string-append "\\`"
-                                     (regexp-group "us-ascii"
-                                                   "iso-8859-[0-9]+"
-                                                   "windows-[0-9]+")
-                                     "\\'")
-                      (mime-body-parameter body 'CHARSET "us-ascii")
-                      #t)
-      (let ((text
-            (message-mime-body-part
-             message
-             (if (or (not enclosure)
-                     (and (eq? (mime-body-type enclosure) 'MESSAGE)
-                          (eq? (mime-body-subtype enclosure) 'RFC822)))
-                 `(,@selector TEXT)
-                 selector)
-             #t)))
-       (call-with-auto-wrapped-output-mark mark
-         (lambda (port)
-           (case (let ((encoding
-                        (and enclosure
-                             (eq? (mime-body-type enclosure) 'MESSAGE)
-                             (eq? (mime-body-subtype enclosure) 'RFC822)
-                             (mime-body-one-part-encoding enclosure))))
-                   (if (and encoding
-                            (not (memq encoding '(7BIT 8BIT BINARY))))
-                       ;; This is completely illegal, but Netscape does
-                       ;; this so we'd better handle it.
-                       encoding
-                       (mime-body-one-part-encoding body)))
-             ((QUOTED-PRINTABLE)
-              (decode-quoted-printable-string text port #t))
-             ((BASE64)
-              (decode-base64-string text port #t))
-             (else
-              (write-string text port)))))
-       (guarantee-newline mark))
-      (insert-mime-message-binary message body enclosure selector mark)))
+  (let* ((message-enclosure?
+         (and enclosure
+              (eq? (mime-body-type enclosure) 'MESSAGE)
+              (eq? (mime-body-subtype enclosure) 'RFC822)))
+        (encoding
+         (let ((encoding
+                (and message-enclosure?
+                     (mime-body-one-part-encoding enclosure))))
+           (if (and encoding (not (memq encoding '(7BIT 8BIT BINARY))))
+               ;; This is illegal, but Netscape does it.
+               encoding
+               (mime-body-one-part-encoding body)))))
+    (if (and (eq? (mime-body-subtype body) 'PLAIN)
+            (known-mime-encoding? encoding)
+            (re-string-match (string-append "\\`"
+                                            (regexp-group "us-ascii"
+                                                          "iso-8859-[0-9]+"
+                                                          "windows-[0-9]+")
+                                            "\\'")
+                             (mime-body-parameter body 'CHARSET "us-ascii")
+                             #t))
+       (let ((text
+              (message-mime-body-part
+               message
+               (if (or (not enclosure) message-enclosure?)
+                   `(,@selector TEXT)
+                   selector)
+               #t)))
+         (call-with-auto-wrapped-output-mark mark
+           (lambda (port)
+             (case encoding
+               ((QUOTED-PRINTABLE)
+                (decode-quoted-printable-string text port #t))
+               ((BASE64)
+                (decode-base64-string text port #t))
+               (else
+                (write-string text port)))))
+         (guarantee-newline mark))
+       (insert-mime-message-binary message body enclosure selector mark))))
 \f
 (define (insert-mime-message-binary message body enclosure selector mark)
   message enclosure
+  (insert-mime-message-attachment 'ATTACHMENT class body selector mark))
+
+(define (insert-mime-message-attachment class body selector mark)
   (let ((start (mark-right-inserting-copy mark)))
-    (insert-string "<IMAIL-ATTACHMENT " mark)
+    (insert-string "<IMAIL-" mark)
+    (insert-string (string-upcase (symbol->string class)) mark)
+    (insert-string " " mark)
     (let ((column (mark-column mark)))
       (let ((name (mime-attachment-name body selector #f)))
        (if name
@@ -1142,10 +1149,13 @@ With prefix argument N moves backward N messages with these flags."
            (insert-string "charset=" mark)
            (insert (mime-body-parameter body 'CHARSET "us-ascii") mark)
            (insert-newline mark)))
-      (change-column column mark)
-      (insert-string "encoding=" mark)
-      (insert (mime-body-one-part-encoding body) mark)
-      (insert-newline mark)
+      (let ((encoding (mime-body-one-part-encoding body)))
+       (if (not (known-mime-encoding? encoding))
+           (begin
+             (change-column column mark)
+             (insert-string "encoding=" mark)
+             (insert encoding mark)
+             (insert-newline mark))))
       (change-column column mark)
       (insert-string "length=" mark)
       (insert (mime-body-one-part-n-octets body) mark))
@@ -1154,6 +1164,9 @@ With prefix argument N moves backward N messages with these flags."
     (mark-temporary! start))
   (insert-newline mark))
 
+(define (known-mime-encoding? encoding)
+  (memq encoding '(7BIT 8BIT BINARY QUOTED-PRINTABLE BASE64)))
+
 (define (mime-attachment-name body selector provide-default?)
   (or (mime-body-parameter body 'NAME #f)
       (and provide-default?

diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index 0df71edc236b7499b8c001303ea0937a0d0f0c48..9140c601549e83d2118db592e9cc62d987cade68 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.69 2000/06/08 04:16:53 cph Exp $
+$Id: todo.txt,v 1.70 2000/06/08 17:16:58 cph Exp $
 
 Bug fixes
 ---------
@@ -9,9 +9,6 @@ Bug fixes
   attribute and uses the message indexes.  It should pay attention to
   UNSEEN and to UIDNEXT to figure out what it needs to do.
 
-* Treat messages in unrecognized encodings as type
-  application/octet-stream.
-
 * M-x imail-copy-messages re-reads the target folder UIDs for each
   message that is written, when the target folder is not being
   visited.  [I haven't seen this lately.  Maybe it's fixed?]
@@ -25,9 +22,6 @@ Bug fixes
 New features
 ------------
 
-* Show suppressed parts of multipart/alternative as attachments in
-  cast the user wants to view them.
-
 * Command to expand attachment inline.  Sometimes attachments aren't
   big binary things but small text things that are easier to view
   inline.