From 954e662ba514ca60384c639bc2d952f4233454b5 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 8 Jun 2000 17:16:58 +0000 Subject: [PATCH] Show alternative forms as attachments in MIME multipart/alternative. Don't show text messages with unknown encodings. --- v7/src/imail/imail-top.scm | 133 ++++++++++++++++++++----------------- v7/src/imail/todo.txt | 8 +-- 2 files changed, 74 insertions(+), 67 deletions(-) diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index fecdff08b..c1601f1cb 100644 --- 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 ) 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)))))) (define-method insert-mime-message-part (message (body ) 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 ) 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)))) (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 "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 0df71edc2..9140c6015 100644 --- 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. -- 2.25.1