From 0e2912a51da1c7a9def046511457391c883663e1 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 1 Jun 2000 20:10:21 +0000
Subject: [PATCH] Initial cut at MIME decoding support.
---
v7/src/imail/imail-top.scm | 130 ++++++++++++++++++++++++++++++-------
v7/src/imail/imail.pkg | 3 +-
v7/src/imail/load.scm | 3 +-
3 files changed, 111 insertions(+), 25 deletions(-)
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 36d631e83..f7c18c44c 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.115 2000/05/31 02:10:35 cph Exp $
+;;; $Id: imail-top.scm,v 1.116 2000/06/01 20:09:12 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
@@ -123,6 +123,12 @@ This has no effect on file-based folders.
Set this variable to #F to disable updating."
600
(lambda (x) (or (not x) (and (exact-integer? x) (positive? x)))))
+
+(define-variable imail-receive-mime
+ "If true, MIME messages are decoded before being presented.
+Otherwise, all messages are presented as plain text."
+ #t
+ boolean?)
(define-command imail
"Read and edit incoming mail.
@@ -678,10 +684,14 @@ With prefix argument N moves backward N messages with these flags."
(header-fields->string
(if full-headers?
(message-header-fields message)
- (maybe-reformat-headers message buffer)))
+ (maybe-reformat-headers (message-header-fields message)
+ buffer)))
mark)
(insert-newline mark)
- (insert-string (message-body message) mark)
+ (if (and (ref-variable imail-receive-mime buffer)
+ (folder-supports-mime? folder))
+ (insert-mime-message-body message mark)
+ (insert-string (message-body message) mark))
(guarantee-newline mark))
(insert-string "[This folder has no messages in it.]" mark))
(mark-temporary! mark))
@@ -692,6 +702,81 @@ With prefix argument N moves backward N messages with these flags."
(message-seen message))
(folder-event folder 'SELECT-MESSAGE message)))
+(define (insert-mime-message-body message mark)
+ (insert-mime-message-part message
+ (message-mime-body-structure message)
+ '()
+ mark))
+
+(define-generic insert-mime-message-part (message body selector mark))
+
+(define-method insert-mime-message-part
+ (message (body <mime-body-multipart>) selector mark)
+ (let ((parts (mime-body-multipart-parts body)))
+ (if (eq? (mime-body-subtype body) 'ALTERNATIVE)
+ (insert-mime-message-part message (car parts) `(,@selector 0) mark)
+ (do ((parts parts (cdr parts))
+ (i 0 (fix:+ i 1)))
+ ((null? parts))
+ (if (fix:> i 0)
+ (insert-mime-message-separator mark))
+ (insert-mime-message-part message (car parts) `(,@selector ,i)
+ mark)))))
+
+(define (insert-mime-message-separator mark)
+ (insert-string "\n----------------------------------------\n\n" mark))
+
+(define-method insert-mime-message-part
+ (message (body <mime-body-text>) selector mark)
+ (let ((text
+ (if (null? selector)
+ (message-body message)
+ (message-mime-body-part message selector))))
+ (if (let ((charset
+ (let ((entry (assq 'CHARSET (mime-body-parameters body))))
+ (if entry
+ (cdr entry)
+ "us-ascii"))))
+ (or (string-ci=? charset "us-ascii")
+ (re-string-match "^iso-8859-[0-9]+$" charset #t)))
+ (begin
+ (case (mime-body-one-part-encoding body)
+ ((QUOTED-PRINTABLE)
+ (insert-string (decode-quoted-printable-string text) mark))
+ ((BASE64)
+ (call-with-values (lambda () (decode-base64-text-string text #f))
+ (lambda (decoded-text pending-return?)
+ (insert-string decoded-text mark)
+ (if pending-return?
+ (insert-char #\return mark)))))
+ (else
+ (insert-string text mark)))
+ (guarantee-newline mark))
+ (insert-mime-message-binary message body selector mark))))
+
+(define-method insert-mime-message-part
+ (message (body <mime-body-message>) selector mark)
+ (insert-string
+ (header-fields->string
+ (maybe-reformat-headers
+ (string->header-fields
+ (message-mime-body-part message `(,@selector HEADER)))
+ mark))
+ mark)
+ (insert-newline mark)
+ (insert-mime-message-part message
+ (mime-body-message-body body)
+ selector
+ mark))
+
+(define-method insert-mime-message-part
+ (message (body <mime-body>) selector mark)
+ (insert-mime-message-binary message body selector mark))
+
+(define (insert-mime-message-binary message body selector mark)
+ message body selector
+ (insert-string "[** ATTACHMENT **]\n" mark))
+
(define (associate-imail-with-buffer buffer folder message)
(without-interrupts
(lambda ()
@@ -897,27 +982,26 @@ With prefix argument N moves backward N messages with these flags."
" 0/0"))
""))))))
-(define (maybe-reformat-headers message buffer)
+(define (maybe-reformat-headers headers buffer)
(let ((headers
- (let ((headers (message-header-fields message)))
- (cond ((ref-variable imail-kept-headers buffer)
- => (lambda (regexps)
- (append-map!
- (lambda (regexp)
- (list-transform-positive headers
- (lambda (header)
- (re-string-match regexp
- (header-field-name header)
- #t))))
- regexps)))
- ((ref-variable imail-ignored-headers buffer)
- => (lambda (regexp)
- (list-transform-negative headers
- (lambda (header)
- (re-string-match regexp
- (header-field-name header)
- #t)))))
- (else headers))))
+ (cond ((ref-variable imail-kept-headers buffer)
+ => (lambda (regexps)
+ (append-map!
+ (lambda (regexp)
+ (list-transform-positive headers
+ (lambda (header)
+ (re-string-match regexp
+ (header-field-name header)
+ #t))))
+ regexps)))
+ ((ref-variable imail-ignored-headers buffer)
+ => (lambda (regexp)
+ (list-transform-negative headers
+ (lambda (header)
+ (re-string-match regexp
+ (header-field-name header)
+ #t)))))
+ (else headers)))
(filter (ref-variable imail-message-filter buffer)))
(if filter
(map (lambda (n.v)
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index c97ecfefe..ceefbb2d2 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: imail.pkg,v 1.43 2000/06/01 20:07:37 cph Exp $
+;;; $Id: imail.pkg,v 1.44 2000/06/01 20:10:14 cph Exp $
;;;
;;; Copyright (c) 2000 Massachusetts Institute of Technology
;;;
@@ -267,6 +267,7 @@
edwin-variable$imail-message-filter
edwin-variable$imail-mode-hook
edwin-variable$imail-primary-folder
+ edwin-variable$imail-receive-mime
edwin-variable$imail-reply-with-re
edwin-variable$imail-summary-highlight-message
edwin-variable$imail-summary-mode-hook
diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm
index 7985d2142..6139a6792 100644
--- a/v7/src/imail/load.scm
+++ b/v7/src/imail/load.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: load.scm,v 1.12 2000/05/30 20:21:52 cph Exp $
+;;; $Id: load.scm,v 1.13 2000/06/01 20:10:21 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
@@ -90,6 +90,7 @@
edwin-variable$imail-mode-hook
edwin-variable$imail-pass-phrase-retention-time
edwin-variable$imail-primary-folder
+ edwin-variable$imail-receive-mime
edwin-variable$imail-reply-with-re
edwin-variable$imail-summary-highlight-message
edwin-variable$imail-summary-mode-hook
--
2.25.1