aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKenichi Handa2010-11-26 13:06:59 +0900
committerKenichi Handa2010-11-26 13:06:59 +0900
commitd1be4ec2743387d7b8c0c5c83ca97fb345a0b4b2 (patch)
tree825910f5efd00c0518b6661081ee8d742eb7254a
parente957f9ae90f3cab1584c06877cbff075d52a6a9a (diff)
downloademacs-d1be4ec2743387d7b8c0c5c83ca97fb345a0b4b2.tar.gz
emacs-d1be4ec2743387d7b8c0c5c83ca97fb345a0b4b2.zip
Improve rmail's MIME handling.
-rw-r--r--lisp/ChangeLog43
-rw-r--r--lisp/mail/rmail.el53
-rw-r--r--lisp/mail/rmailmm.el367
-rw-r--r--lisp/mail/rmailsum.el22
4 files changed, 419 insertions, 66 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index fc460eaaf3d..812c66d3df6 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,46 @@
12010-11-26 Kenichi Handa <handa@m17n.org>
2
3 * mail/rmailmm.el (rmail-mime-entity, rmail-mime-entity-type)
4 (rmail-mime-entity-disposition)
5 (rmail-mime-entity-transfer-encoding, rmail-mime-entity-header)
6 (rmail-mime-entity-body, rmail-mime-entity-children): New functions.
7 (rmail-mime-save): Handle the case that the button's `data' is a
8 MIME entity.
9 (rmail-mime-insert-text): New function.
10 (rmail-mime-insert-image): Handle the case that DATA is a MIME
11 entity.
12 (rmail-mime-bulk-handler): Just call rmail-mime-insert-bulk.
13 (rmail-mime-insert-bulk): New function mostly copied from the old
14 rmail-mime-bulk-handler.
15 (rmail-mime-multipart-handler): Just call
16 rmail-mime-process-multipart.
17 (rmail-mime-process-multipart): New funciton mostly copied from
18 the old rmail-mime-multipart-handler.
19 (rmail-mime-show): Just call rmail-mime-process.
20 (rmail-mime-process): New funciton mostly copied from the old
21 rmail-mime-show.
22 (rmail-mime-insert-multipart, rmail-mime-parse)
23 (rmail-mime-insert, rmail-show-mime)
24 (rmail-insert-mime-forwarded-message)
25 (rmail-insert-mime-resent-message): New functions.
26 (rmail-insert-mime-forwarded-message-function): Set to
27 rmail-insert-mime-forwarded-message.
28 (rmail-insert-mime-resent-message-function): Set to
29 rmail-insert-mime-resent-message.
30
31 * mail/rmailsum.el: Require rfc2047.
32 (rmail-header-summary): Handle multiline Subject: field.
33 (rmail-summary-line-decoder): Change the default to
34 rfc2047-decode-string.
35
36 * mail/rmail.el (rmail-enable-mime): Change the default to t.
37 (rmail-mime-feature): Change the default to `rmailmm'.
38 (rmail-quit): Delete the specifal code for rmail-enable-mime.
39 (rmail-display-labels): Likewise.
40 (rmail-show-message-1): Check rmail-enable-mime, and use
41 rmail-show-mime-function for a MIME message. Decode the headers
42 according to RFC2047.
43
12010-11-24 Stefan Monnier <monnier@iro.umontreal.ca> 442010-11-24 Stefan Monnier <monnier@iro.umontreal.ca>
2 45
3 * progmodes/which-func.el (which-func-imenu-joiner-function): 46 * progmodes/which-func.el (which-func-imenu-joiner-function):
diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el
index 3ab87fa21f7..70c84a242f5 100644
--- a/lisp/mail/rmail.el
+++ b/lisp/mail/rmail.el
@@ -638,7 +638,7 @@ Element N specifies the summary line for message N+1.")
638 638
639This is set to nil by default.") 639This is set to nil by default.")
640 640
641(defcustom rmail-enable-mime nil 641(defcustom rmail-enable-mime t
642 "If non-nil, RMAIL uses MIME features. 642 "If non-nil, RMAIL uses MIME features.
643If the value is t, RMAIL automatically shows MIME decoded message. 643If the value is t, RMAIL automatically shows MIME decoded message.
644If the value is neither t nor nil, RMAIL does not show MIME decoded message 644If the value is neither t nor nil, RMAIL does not show MIME decoded message
@@ -649,6 +649,7 @@ unless the feature specified by `rmail-mime-feature' is available."
649 :type '(choice (const :tag "on" t) 649 :type '(choice (const :tag "on" t)
650 (const :tag "off" nil) 650 (const :tag "off" nil)
651 (other :tag "when asked" ask)) 651 (other :tag "when asked" ask))
652 :version "23.3"
652 :group 'rmail) 653 :group 'rmail)
653 654
654(defvar rmail-enable-mime-composing nil 655(defvar rmail-enable-mime-composing nil
@@ -693,13 +694,12 @@ start of the header) with three arguments MSG, REGEXP, and LIMIT,
693where MSG is the message number, REGEXP is the regular 694where MSG is the message number, REGEXP is the regular
694expression, LIMIT is the position specifying the end of header.") 695expression, LIMIT is the position specifying the end of header.")
695 696
696(defvar rmail-mime-feature 'rmail-mime 697(defvar rmail-mime-feature 'rmailmm
697 "Feature to require to load MIME support in Rmail. 698 "Feature to require to load MIME support in Rmail.
698When starting Rmail, if `rmail-enable-mime' is non-nil, 699When starting Rmail, if `rmail-enable-mime' is non-nil,
699this feature is required with `require'. 700this feature is required with `require'.
700 701
701The default value is `rmail-mime'. This feature is provided by 702The default value is `rmailmm'")
702the rmail-mime package available at <http://www.m17n.org/rmail-mime/>.")
703 703
704;; FIXME this is unused. 704;; FIXME this is unused.
705(defvar rmail-decode-mime-charset t 705(defvar rmail-decode-mime-charset t
@@ -1509,17 +1509,9 @@ Hook `rmail-quit-hook' is run after expunging."
1509 (set-buffer-modified-p nil)) 1509 (set-buffer-modified-p nil))
1510 (replace-buffer-in-windows rmail-summary-buffer) 1510 (replace-buffer-in-windows rmail-summary-buffer)
1511 (bury-buffer rmail-summary-buffer)) 1511 (bury-buffer rmail-summary-buffer))
1512 (if rmail-enable-mime 1512 (let ((obuf (current-buffer)))
1513 (let ((obuf rmail-buffer) 1513 (quit-window)
1514 (ovbuf rmail-view-buffer)) 1514 (replace-buffer-in-windows obuf)))
1515 (set-buffer rmail-view-buffer)
1516 (quit-window)
1517 (replace-buffer-in-windows ovbuf)
1518 (replace-buffer-in-windows obuf)
1519 (bury-buffer obuf))
1520 (let ((obuf (current-buffer)))
1521 (quit-window)
1522 (replace-buffer-in-windows obuf))))
1523 1515
1524(defun rmail-bury () 1516(defun rmail-bury ()
1525 "Bury current Rmail buffer and its summary buffer." 1517 "Bury current Rmail buffer and its summary buffer."
@@ -2219,15 +2211,7 @@ If nil, that means the current message."
2219 (let ((blurb (rmail-get-labels))) 2211 (let ((blurb (rmail-get-labels)))
2220 (setq mode-line-process 2212 (setq mode-line-process
2221 (format " %d/%d%s" 2213 (format " %d/%d%s"
2222 rmail-current-message rmail-total-messages blurb)) 2214 rmail-current-message rmail-total-messages blurb))))
2223 ;; If rmail-enable-mime is non-nil, we may have to update
2224 ;; `mode-line-process' of rmail-view-buffer too.
2225 (if (and rmail-enable-mime
2226 (not (eq (current-buffer) rmail-view-buffer))
2227 (buffer-live-p rmail-view-buffer))
2228 (let ((mlp mode-line-process))
2229 (with-current-buffer rmail-view-buffer
2230 (setq mode-line-process mlp))))))
2231 2215
2232(defun rmail-get-attr-value (attr state) 2216(defun rmail-get-attr-value (attr state)
2233 "Return the character value for ATTR. 2217 "Return the character value for ATTR.
@@ -2706,6 +2690,11 @@ The current mail message becomes the message displayed."
2706 (message "Showing message %d" msg)) 2690 (message "Showing message %d" msg))
2707 (narrow-to-region beg end) 2691 (narrow-to-region beg end)
2708 (goto-char beg) 2692 (goto-char beg)
2693 (if (and rmail-enable-mime
2694 (re-search-forward "mime-version: 1.0" nil t))
2695 (let ((rmail-buffer mbox-buf)
2696 (rmail-view-buffer view-buf))
2697 (funcall rmail-show-mime-function))
2709 (setq body-start (search-forward "\n\n" nil t)) 2698 (setq body-start (search-forward "\n\n" nil t))
2710 (narrow-to-region beg (point)) 2699 (narrow-to-region beg (point))
2711 (goto-char beg) 2700 (goto-char beg)
@@ -2722,11 +2711,6 @@ The current mail message becomes the message displayed."
2722 ;; unibyte temporary buffer where the character decoding takes 2711 ;; unibyte temporary buffer where the character decoding takes
2723 ;; place. 2712 ;; place.
2724 (with-current-buffer rmail-view-buffer 2713 (with-current-buffer rmail-view-buffer
2725 ;; We give the view buffer a buffer-local value of
2726 ;; rmail-header-style based on the binding in effect when
2727 ;; this function is called; `rmail-toggle-headers' can
2728 ;; inspect this value to determine how to toggle.
2729 (set (make-local-variable 'rmail-header-style) header-style)
2730 (erase-buffer)) 2714 (erase-buffer))
2731 (if (null character-coding) 2715 (if (null character-coding)
2732 ;; Do it directly since that is fast. 2716 ;; Do it directly since that is fast.
@@ -2749,8 +2733,13 @@ The current mail message becomes the message displayed."
2749 (error "uuencoded messages are not supported yet")) 2733 (error "uuencoded messages are not supported yet"))
2750 (t)) 2734 (t))
2751 (rmail-decode-region (point-min) (point-max) 2735 (rmail-decode-region (point-min) (point-max)
2752 coding-system view-buf))) 2736 coding-system view-buf))))
2753 (with-current-buffer rmail-view-buffer 2737 (with-current-buffer rmail-view-buffer
2738 ;; We give the view buffer a buffer-local value of
2739 ;; rmail-header-style based on the binding in effect when
2740 ;; this function is called; `rmail-toggle-headers' can
2741 ;; inspect this value to determine how to toggle.
2742 (set (make-local-variable 'rmail-header-style) header-style)
2754 ;; Unquote quoted From lines 2743 ;; Unquote quoted From lines
2755 (goto-char (point-min)) 2744 (goto-char (point-min))
2756 (while (re-search-forward "^>+From " nil t) 2745 (while (re-search-forward "^>+From " nil t)
@@ -2766,6 +2755,10 @@ The current mail message becomes the message displayed."
2766 (with-current-buffer rmail-view-buffer 2755 (with-current-buffer rmail-view-buffer
2767 (insert "\n") 2756 (insert "\n")
2768 (goto-char (point-min)) 2757 (goto-char (point-min))
2758 ;; Decode the headers according to RFC2047.
2759 (save-excursion
2760 (search-forward "\n\n" nil 'move)
2761 (rfc2047-decode-region (point-min) (point)))
2769 (rmail-highlight-headers) 2762 (rmail-highlight-headers)
2770 ;(rmail-activate-urls) 2763 ;(rmail-activate-urls)
2771 ;(rmail-process-quoted-material) 2764 ;(rmail-process-quoted-material)
diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el
index e8ca11ee349..6dfa92aa93a 100644
--- a/lisp/mail/rmailmm.el
+++ b/lisp/mail/rmailmm.el
@@ -26,17 +26,57 @@
26 26
27;; Essentially based on the design of Alexander Pohoyda's MIME 27;; Essentially based on the design of Alexander Pohoyda's MIME
28;; extensions (mime-display.el and mime.el). 28;; extensions (mime-display.el and mime.el).
29;; Call `M-x rmail-mime' when viewing an Rmail message. 29
30;; This file provides two operation modes for viewing a MIME message.
31
32;; (1) When rmail-enable-mime is non-nil (now it is the default), the
33;; function `rmail-show-mime' is automatically called. That function
34;; shows a MIME message directly in RMAIL's view buffer.
35
36;; (2) When rmail-enable-mime is nil, the command 'v' (or M-x
37;; rmail-mime) shows a MIME message in a new buffer "*RMAIL*".
38
39;; Both operations share the intermediate functions rmail-mime-process
40;; and rmail-mime-process-multipart as below.
41
42;; rmail-show-mime
43;; +- rmail-mime-parse
44;; | +- rmail-mime-process <--+------------+
45;; | | +---------+ |
46;; | + rmail-mime-process-multipart --+
47;; |
48;; + rmail-mime-insert <----------------+
49;; +- rmail-mime-insert-text |
50;; +- rmail-mime-insert-bulk |
51;; +- rmail-mime-insert-multipart --+
52;;
53;; rmail-mime
54;; +- rmail-mime-show <----------------------------------+
55;; +- rmail-mime-process |
56;; +- rmail-mime-handle |
57;; +- rmail-mime-text-handler |
58;; +- rmail-mime-bulk-handler |
59;; | + rmail-mime-insert-bulk
60;; +- rmail-mime-multipart-handler |
61;; +- rmail-mime-process-multipart --+
62
63;; In addition, for the case of rmail-enable-mime being non-nil, this
64;; file provides two functions rmail-insert-mime-forwarded-message and
65;; rmail-insert-mime-resent-message for composing forwarded and resent
66;; messages respectively.
30 67
31;; Todo: 68;; Todo:
32 69
33;; Handle multipart/alternative. 70;; Make rmail-mime-media-type-handlers-alist usable in the first
71;; operation mode.
72;; Handle multipart/alternative in the second operation mode.
34;; Offer the option to call external/internal viewers (doc-view, xpdf, etc). 73;; Offer the option to call external/internal viewers (doc-view, xpdf, etc).
35 74
36;;; Code: 75;;; Code:
37 76
38(require 'rmail) 77(require 'rmail)
39(require 'mail-parse) 78(require 'mail-parse)
79(require 'message)
40 80
41;;; User options. 81;;; User options.
42 82
@@ -90,6 +130,52 @@ automatically display the image in the buffer."
90 130
91;;; End of user options. 131;;; End of user options.
92 132
133;;; MIME-entity object
134
135(defun rmail-mime-entity (type disposition transfer-encoding
136 header body children)
137 "Retrun a newly created MIME-entity object.
138
139A MIME-entity is a vector of 6 elements:
140
141 [ TYPE DISPOSITION TRANSFER-ENCODING HEADER BODY CHILDREN ]
142
143TYPE and DISPOSITION correspond to MIME headers Content-Type: and
144Cotent-Disposition: respectively, and has this format:
145
146 \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)
147
148VALUE is a string and ATTRIBUTE is a symbol.
149
150Consider the following header, for example:
151
152Content-Type: multipart/mixed;
153 boundary=\"----=_NextPart_000_0104_01C617E4.BDEC4C40\"
154
155The corresponding TYPE argument must be:
156
157\(\"multipart/mixed\"
158 \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))
159
160TRANSFER-ENCODING corresponds to MIME header
161Content-Transfer-Encoding, and is a lowercased string.
162
163HEADER and BODY are a cons (BEG . END), where BEG and END specify
164the region of the corresponding part in RMAIL's data (mbox)
165buffer. BODY may be nil. In that case, the current buffer is
166narrowed to the body part.
167
168CHILDREN is a list of MIME-entities for a \"multipart\" entity, and
169nil for the other types."
170 (vector type disposition transfer-encoding header body children))
171
172;; Accessors for a MIME-entity object.
173(defsubst rmail-mime-entity-type (entity) (aref entity 0))
174(defsubst rmail-mime-entity-disposition (entity) (aref entity 1))
175(defsubst rmail-mime-entity-transfer-encoding (entity) (aref entity 2))
176(defsubst rmail-mime-entity-header (entity) (aref entity 3))
177(defsubst rmail-mime-entity-body (entity) (aref entity 4))
178(defsubst rmail-mime-entity-children (entity) (aref entity 5))
93 179
94;;; Buttons 180;;; Buttons
95 181
@@ -98,6 +184,7 @@ automatically display the image in the buffer."
98 (let* ((filename (button-get button 'filename)) 184 (let* ((filename (button-get button 'filename))
99 (directory (button-get button 'directory)) 185 (directory (button-get button 'directory))
100 (data (button-get button 'data)) 186 (data (button-get button 'data))
187 (mbox-buf rmail-view-buffer)
101 (ofilename filename)) 188 (ofilename filename))
102 (setq filename (expand-file-name 189 (setq filename (expand-file-name
103 (read-file-name (format "Save as (default: %s): " filename) 190 (read-file-name (format "Save as (default: %s): " filename)
@@ -116,7 +203,17 @@ automatically display the image in the buffer."
116 ;; file, the magic signature compares equal with the unibyte 203 ;; file, the magic signature compares equal with the unibyte
117 ;; signature string recorded in jka-compr-compression-info-list. 204 ;; signature string recorded in jka-compr-compression-info-list.
118 (set-buffer-multibyte nil) 205 (set-buffer-multibyte nil)
119 (insert data) 206 (setq buffer-undo-list t)
207 (if (stringp data)
208 (insert data)
209 ;; DATA is a MIME-entity object.
210 (let ((transfer-encoding (rmail-mime-entity-transfer-encoding data))
211 (body (rmail-mime-entity-body data)))
212 (insert-buffer-substring mbox-buf (car body) (cdr body))
213 (cond ((string= transfer-encoding "base64")
214 (ignore-errors (base64-decode-region (point-min) (point-max))))
215 ((string= transfer-encoding "quoted-printable")
216 (quoted-printable-decode-region (point-min) (point-max))))))
120 (write-region nil nil filename nil nil nil t)))) 217 (write-region nil nil filename nil nil nil t))))
121 218
122(define-button-type 'rmail-mime-save 'action 'rmail-mime-save) 219(define-button-type 'rmail-mime-save 'action 'rmail-mime-save)
@@ -133,6 +230,23 @@ automatically display the image in the buffer."
133 (when (coding-system-p coding-system) 230 (when (coding-system-p coding-system)
134 (decode-coding-region (point-min) (point-max) coding-system)))) 231 (decode-coding-region (point-min) (point-max) coding-system))))
135 232
233(defun rmail-mime-insert-text (entity)
234 "Insert MIME-entity ENTITY as a plain text MIME part in the current buffer."
235 (let* ((content-type (rmail-mime-entity-type entity))
236 (charset (cdr (assq 'charset (cdr content-type))))
237 (coding-system (if charset (intern (downcase charset))))
238 (transfer-encoding (rmail-mime-entity-transfer-encoding entity))
239 (body (rmail-mime-entity-body entity)))
240 (save-restriction
241 (narrow-to-region (point) (point))
242 (insert-buffer-substring rmail-buffer (car body) (cdr body))
243 (cond ((string= transfer-encoding "base64")
244 (ignore-errors (base64-decode-region (point-min) (point-max))))
245 ((string= transfer-encoding "quoted-printable")
246 (quoted-printable-decode-region (point-min) (point-max))))
247 (if (coding-system-p coding-system)
248 (decode-coding-region (point-min) (point-max) coding-system)))))
249
136;; FIXME move to the test/ directory? 250;; FIXME move to the test/ directory?
137(defun test-rmail-mime-handler () 251(defun test-rmail-mime-handler ()
138 "Test of a mail using no MIME parts at all." 252 "Test of a mail using no MIME parts at all."
@@ -151,10 +265,28 @@ MIME-Version: 1.0
151 265
152 266
153(defun rmail-mime-insert-image (type data) 267(defun rmail-mime-insert-image (type data)
154 "Insert an image of type TYPE, where DATA is the image data." 268 "Insert an image of type TYPE, where DATA is the image data.
269If DATA is not a string, it is a MIME-entity object."
155 (end-of-line) 270 (end-of-line)
156 (insert ?\n) 271 (let ((modified (buffer-modified-p)))
157 (insert-image (create-image data type t))) 272 (insert ?\n)
273 (unless (stringp data)
274 ;; DATA is a MIME-entity.
275 (let ((transfer-encoding (rmail-mime-entity-transfer-encoding data))
276 (body (rmail-mime-entity-body data))
277 (mbox-buffer rmail-view-buffer))
278 (with-temp-buffer
279 (set-buffer-multibyte nil)
280 (setq buffer-undo-list t)
281 (insert-buffer-substring mbox-buffer (car body) (cdr body))
282 (cond ((string= transfer-encoding "base64")
283 (ignore-errors (base64-decode-region (point-min) (point-max))))
284 ((string= transfer-encoding "quoted-printable")
285 (quoted-printable-decode-region (point-min) (point-max))))
286 (setq data
287 (buffer-substring-no-properties (point-min) (point-max))))))
288 (insert-image (create-image data type t))
289 (set-buffer-modified-p modified)))
158 290
159(defun rmail-mime-image (button) 291(defun rmail-mime-image (button)
160 "Display the image associated with BUTTON." 292 "Display the image associated with BUTTON."
@@ -171,8 +303,19 @@ MIME-Version: 1.0
171 "Handle the current buffer as an attachment to download. 303 "Handle the current buffer as an attachment to download.
172For images that Emacs is capable of displaying, the behavior 304For images that Emacs is capable of displaying, the behavior
173depends upon the value of `rmail-mime-show-images'." 305depends upon the value of `rmail-mime-show-images'."
306 (rmail-mime-insert-bulk
307 (rmail-mime-entity content-type content-disposition content-transfer-encoding
308 nil nil nil)))
309
310(defun rmail-mime-insert-bulk (entity)
311 "Inesrt a MIME-entity ENTITY as an attachment.
312The optional second arg DATA, if non-nil, is a string containing
313the attachment data that is already decoded."
174 ;; Find the default directory for this media type. 314 ;; Find the default directory for this media type.
175 (let* ((directory (catch 'directory 315 (let* ((content-type (rmail-mime-entity-type entity))
316 (content-disposition (rmail-mime-entity-disposition entity))
317 (body (rmail-mime-entity-body entity))
318 (directory (catch 'directory
176 (dolist (entry rmail-mime-attachment-dirs-alist) 319 (dolist (entry rmail-mime-attachment-dirs-alist)
177 (when (string-match (car entry) (car content-type)) 320 (when (string-match (car entry) (car content-type))
178 (dolist (dir (cdr entry)) 321 (dolist (dir (cdr entry))
@@ -182,17 +325,21 @@ depends upon the value of `rmail-mime-show-images'."
182 (cdr (assq 'filename (cdr content-disposition))) 325 (cdr (assq 'filename (cdr content-disposition)))
183 "noname")) 326 "noname"))
184 (label (format "\nAttached %s file: " (car content-type))) 327 (label (format "\nAttached %s file: " (car content-type)))
185 (data (buffer-string))
186 (udata (string-as-unibyte data))
187 (size (length udata))
188 (osize size)
189 (units '(B kB MB GB)) 328 (units '(B kB MB GB))
190 type) 329 data udata size osize type)
191 (while (and (> size 1024.0) ; cribbed from gnus-agent-expire-done-message 330 (if body
331 (setq data entity
332 udata entity
333 size (- (cdr body) (car body)))
334 (setq data (buffer-string)
335 udata (string-as-unibyte data)
336 size (length udata))
337 (delete-region (point-min) (point-max)))
338 (setq osize size)
339 (while (and (> size 1024.0) ; cribbed from gnus-agent-expire-done-message
192 (cdr units)) 340 (cdr units))
193 (setq size (/ size 1024.0) 341 (setq size (/ size 1024.0)
194 units (cdr units))) 342 units (cdr units)))
195 (delete-region (point-min) (point-max))
196 (insert label) 343 (insert label)
197 (insert-button filename 344 (insert-button filename
198 :type 'rmail-mime-save 345 :type 'rmail-mime-save
@@ -248,6 +395,22 @@ The current buffer should be narrowed to the body. CONTENT-TYPE,
248CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values 395CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values
249of the respective parsed headers. See `rmail-mime-handle' for their 396of the respective parsed headers. See `rmail-mime-handle' for their
250format." 397format."
398 (rmail-mime-process-multipart
399 content-type content-disposition content-transfer-encoding nil))
400
401(defun rmail-mime-process-multipart (content-type
402 content-disposition
403 content-transfer-encoding
404 parse-only)
405 "Process the current buffer as a multipart MIME body.
406
407If PARSE-ONLY is nil, modify the current buffer directly for showing
408the MIME body and return nil.
409
410Otherwise, just parse the current buffer and return a list of
411MIME-entity objects.
412
413The other arguments are the same as `rmail-mime-multipart-handler'."
251 ;; Some MUAs start boundaries with "--", while it should start 414 ;; Some MUAs start boundaries with "--", while it should start
252 ;; with "CRLF--", as defined by RFC 2046: 415 ;; with "CRLF--", as defined by RFC 2046:
253 ;; The boundary delimiter MUST occur at the beginning of a line, 416 ;; The boundary delimiter MUST occur at the beginning of a line,
@@ -256,7 +419,7 @@ format."
256 ;; of the preceding part. 419 ;; of the preceding part.
257 ;; We currently don't handle that. 420 ;; We currently don't handle that.
258 (let ((boundary (cdr (assq 'boundary content-type))) 421 (let ((boundary (cdr (assq 'boundary content-type)))
259 beg end next) 422 beg end next entities)
260 (unless boundary 423 (unless boundary
261 (rmail-mm-get-boundary-error-message 424 (rmail-mm-get-boundary-error-message
262 "No boundary defined" content-type content-disposition 425 "No boundary defined" content-type content-disposition
@@ -266,7 +429,9 @@ format."
266 (goto-char (point-min)) 429 (goto-char (point-min))
267 (when (and (search-forward boundary nil t) 430 (when (and (search-forward boundary nil t)
268 (looking-at "[ \t]*\n")) 431 (looking-at "[ \t]*\n"))
269 (delete-region (point-min) (match-end 0))) 432 (if parse-only
433 (narrow-to-region (match-end 0) (point-max))
434 (delete-region (point-min) (match-end 0))))
270 ;; Loop over all body parts, where beg points at the beginning of 435 ;; Loop over all body parts, where beg points at the beginning of
271 ;; the part and end points at the end of the part. next points at 436 ;; the part and end points at the end of the part. next points at
272 ;; the beginning of the next part. 437 ;; the beginning of the next part.
@@ -284,13 +449,17 @@ format."
284 (rmail-mm-get-boundary-error-message 449 (rmail-mm-get-boundary-error-message
285 "Malformed boundary" content-type content-disposition 450 "Malformed boundary" content-type content-disposition
286 content-transfer-encoding))) 451 content-transfer-encoding)))
287 (delete-region end next)
288 ;; Handle the part. 452 ;; Handle the part.
289 (save-restriction 453 (if parse-only
290 (narrow-to-region beg end) 454 (save-restriction
291 (rmail-mime-show)) 455 (narrow-to-region beg end)
292 (goto-char (setq beg next))))) 456 (setq entities (cons (rmail-mime-process nil t) entities)))
293 457 (delete-region end next)
458 (save-restriction
459 (narrow-to-region beg end)
460 (rmail-mime-show)))
461 (goto-char (setq beg next)))
462 (nreverse entities)))
294 463
295(defun test-rmail-mime-multipart-handler () 464(defun test-rmail-mime-multipart-handler ()
296 "Test of a mail used as an example in RFC 2046." 465 "Test of a mail used as an example in RFC 2046."
@@ -393,6 +562,9 @@ called recursively if multiple parts are available.
393 562
394The current buffer must contain a single message. It will be 563The current buffer must contain a single message. It will be
395modified." 564modified."
565 (rmail-mime-process show-headers nil))
566
567(defun rmail-mime-process (show-headers parse-only)
396 (let ((end (point-min)) 568 (let ((end (point-min))
397 content-type 569 content-type
398 content-transfer-encoding 570 content-transfer-encoding
@@ -436,14 +608,105 @@ modified."
436 ;; attachment according to RFC 2183. 608 ;; attachment according to RFC 2183.
437 (unless (member (car content-disposition) '("inline" "attachment")) 609 (unless (member (car content-disposition) '("inline" "attachment"))
438 (setq content-disposition '("attachment"))) 610 (setq content-disposition '("attachment")))
439 ;; Hide headers and handle the part. 611
440 (save-restriction 612 (if parse-only
441 (cond ((string= (car content-type) "message/rfc822") 613 (cond ((string-match "multipart/.*" (car content-type))
442 (narrow-to-region end (point-max))) 614 (setq end (1- end))
443 ((not show-headers) 615 (save-restriction
444 (delete-region (point-min) end))) 616 (let ((header (if show-headers (cons (point-min) end))))
445 (rmail-mime-handle content-type content-disposition 617 (narrow-to-region end (point-max))
446 content-transfer-encoding)))) 618 (rmail-mime-entity content-type
619 content-disposition
620 content-transfer-encoding
621 header nil
622 (rmail-mime-process-multipart
623 content-type content-disposition
624 content-transfer-encoding t)))))
625 ((string-match "message/rfc822" (car content-type))
626 (or show-headers
627 (narrow-to-region end (point-max)))
628 (rmail-mime-process t t))
629 (t
630 (rmail-mime-entity content-type
631 content-disposition
632 content-transfer-encoding
633 nil
634 (cons end (point-max))
635 nil)))
636 ;; Hide headers and handle the part.
637 (save-restriction
638 (cond ((string= (car content-type) "message/rfc822")
639 (narrow-to-region end (point-max)))
640 ((not show-headers)
641 (delete-region (point-min) end)))
642 (rmail-mime-handle content-type content-disposition
643 content-transfer-encoding)))))
644
645(defun rmail-mime-insert-multipart (entity)
646 "Insert MIME-entity ENTITY of multipart type in the current buffer."
647 (let ((subtype (cadr (split-string (car (rmail-mime-entity-type entity))
648 "/")))
649 (disposition (rmail-mime-entity-disposition entity))
650 (header (rmail-mime-entity-header entity))
651 (children (rmail-mime-entity-children entity)))
652 (if header
653 (let ((pos (point)))
654 (or (bolp)
655 (insert "\n"))
656 (insert-buffer-substring rmail-buffer (car header) (cdr header))
657 (rfc2047-decode-region pos (point))
658 (insert "\n")))
659 (cond
660 ((string= subtype "mixed")
661 (dolist (child children)
662 (rmail-mime-insert child '("text/plain") disposition)))
663 ((string= subtype "digest")
664 (dolist (child children)
665 (rmail-mime-insert child '("message/rfc822") disposition)))
666 ((string= subtype "alternative")
667 (let (best-plain-text best-text)
668 (dolist (child children)
669 (if (string= (or (car (rmail-mime-entity-disposition child))
670 (car disposition))
671 "inline")
672 (if (string-match "text/plain"
673 (car (rmail-mime-entity-type child)))
674 (setq best-plain-text child)
675 (if (string-match "text/.*"
676 (car (rmail-mime-entity-type child)))
677 (setq best-text child)))))
678 (if (or best-plain-text best-text)
679 (rmail-mime-insert (or best-plain-text best-text))
680 ;; No child could be handled. Insert all.
681 (dolist (child children)
682 (rmail-mime-insert child nil disposition)))))
683 (t
684 ;; Unsupported subtype. Insert all as attachment.
685 (dolist (child children)
686 (rmail-mime-insert-bulk child))))))
687
688(defun rmail-mime-parse ()
689 "Parse the current Rmail message as a MIME message.
690The value is a MIME-entiy object (see `rmail-mime-enty-new')."
691 (save-excursion
692 (goto-char (point-min))
693 (rmail-mime-process nil t)))
694
695(defun rmail-mime-insert (entity &optional content-type disposition)
696 "Insert a MIME-entity ENTITY in the current buffer.
697
698This function will be called recursively if multiple parts are
699available."
700 (if (rmail-mime-entity-children entity)
701 (rmail-mime-insert-multipart entity)
702 (setq content-type
703 (or (rmail-mime-entity-type entity) content-type))
704 (setq disposition
705 (or (rmail-mime-entity-disposition entity) disposition))
706 (if (and (string= (car disposition) "inline")
707 (string-match "text/.*" (car content-type)))
708 (rmail-mime-insert-text entity)
709 (rmail-mime-insert-bulk entity))))
447 710
448(define-derived-mode rmail-mime-mode fundamental-mode "RMIME" 711(define-derived-mode rmail-mime-mode fundamental-mode "RMIME"
449 "Major mode used in `rmail-mime' buffers." 712 "Major mode used in `rmail-mime' buffers."
@@ -479,6 +742,50 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'."
479 (error "%s; type: %s; disposition: %s; encoding: %s" 742 (error "%s; type: %s; disposition: %s; encoding: %s"
480 message type disposition encoding)) 743 message type disposition encoding))
481 744
745(defun rmail-show-mime ()
746 (let ((mbox-buf rmail-buffer))
747 (condition-case nil
748 (let ((entity (rmail-mime-parse)))
749 (with-current-buffer rmail-view-buffer
750 (let ((inhibit-read-only t)
751 (rmail-buffer mbox-buf))
752 (erase-buffer)
753 (rmail-mime-insert entity))))
754 (error
755 ;; Decoding failed. Insert the original message body as is.
756 (let ((region (with-current-buffer mbox-buf
757 (goto-char (point-min))
758 (re-search-forward "^$" nil t)
759 (forward-line 1)
760 (cons (point) (point-max)))))
761 (with-current-buffer rmail-view-buffer
762 (let ((inhibit-read-only t))
763 (erase-buffer)
764 (insert-buffer-substring mbox-buf (car region) (cdr region))))
765 (message "MIME decoding failed"))))))
766
767(setq rmail-show-mime-function 'rmail-show-mime)
768
769(defun rmail-insert-mime-forwarded-message (forward-buffer)
770 (let ((mbox-buf (with-current-buffer forward-buffer rmail-view-buffer)))
771 (save-restriction
772 (narrow-to-region (point) (point))
773 (message-forward-make-body-mime mbox-buf))))
774
775(setq rmail-insert-mime-forwarded-message-function
776 'rmail-insert-mime-forwarded-message)
777
778(defun rmail-insert-mime-resent-message (forward-buffer)
779 (insert-buffer-substring
780 (with-current-buffer forward-buffer rmail-view-buffer))
781 (goto-char (point-min))
782 (when (looking-at "From ")
783 (forward-line 1)
784 (delete-region (point-min) (point))))
785
786(setq rmail-insert-mime-resent-message-function
787 'rmail-insert-mime-resent-message)
788
482(provide 'rmailmm) 789(provide 'rmailmm)
483 790
484;; Local Variables: 791;; Local Variables:
diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el
index 80c65cdfb57..2d8019b6834 100644
--- a/lisp/mail/rmailsum.el
+++ b/lisp/mail/rmailsum.el
@@ -31,6 +31,7 @@
31 31
32;; For rmail-select-summary. 32;; For rmail-select-summary.
33(require 'rmail) 33(require 'rmail)
34(require 'rfc2047)
34 35
35(defcustom rmail-summary-scroll-between-messages t 36(defcustom rmail-summary-scroll-between-messages t
36 "Non-nil means Rmail summary scroll commands move between messages. 37 "Non-nil means Rmail summary scroll commands move between messages.
@@ -363,13 +364,15 @@ The current buffer contains the unrestricted message collection."
363 (aset rmail-summary-vector (1- msgnum) line)) 364 (aset rmail-summary-vector (1- msgnum) line))
364 line)) 365 line))
365 366
366(defcustom rmail-summary-line-decoder (function identity) 367(defcustom rmail-summary-line-decoder (function rfc2047-decode-string)
367 "Function to decode a Rmail summary line. 368 "Function to decode a Rmail summary line.
368It receives the summary line for one message as a string 369It receives the summary line for one message as a string
369and should return the decoded string. 370and should return the decoded string.
370 371
371By default, it is `identity', which returns the string unaltered." 372By default, it is `rfc2047-decode-string', which decodes MIME-encoded
373subject."
372 :type 'function 374 :type 'function
375 :version "23.3"
373 :group 'rmail-summary) 376 :group 'rmail-summary)
374 377
375(defun rmail-create-summary-line (msgnum) 378(defun rmail-create-summary-line (msgnum)
@@ -588,10 +591,17 @@ the message being processed."
588 (t (- mch 14)))) 591 (t (- mch 14))))
589 (min len (+ lo 25))))))))) 592 (min len (+ lo 25)))))))))
590 (concat (if (re-search-forward "^Subject:" nil t) 593 (concat (if (re-search-forward "^Subject:" nil t)
591 (progn (skip-chars-forward " \t") 594 (let (pos str)
592 (buffer-substring (point) 595 (skip-chars-forward " \t")
593 (progn (end-of-line) 596 (setq pos (point))
594 (point)))) 597 (forward-line 1)
598 (setq str (buffer-substring pos (1- (point))))
599 (while (looking-at "\\s ")
600 (setq str (concat str " "
601 (buffer-substring (match-end 0)
602 (line-end-position))))
603 (forward-line 1))
604 str)
595 (re-search-forward "[\n][\n]+" nil t) 605 (re-search-forward "[\n][\n]+" nil t)
596 (buffer-substring (point) (progn (end-of-line) (point)))) 606 (buffer-substring (point) (progn (end-of-line) (point))))
597 "\n"))) 607 "\n")))