Commit d1be4ec2 authored by Kenichi Handa's avatar Kenichi Handa

Improve rmail's MIME handling.

parent e957f9ae
2010-11-26 Kenichi Handa <handa@m17n.org>
* mail/rmailmm.el (rmail-mime-entity, rmail-mime-entity-type)
(rmail-mime-entity-disposition)
(rmail-mime-entity-transfer-encoding, rmail-mime-entity-header)
(rmail-mime-entity-body, rmail-mime-entity-children): New functions.
(rmail-mime-save): Handle the case that the button's `data' is a
MIME entity.
(rmail-mime-insert-text): New function.
(rmail-mime-insert-image): Handle the case that DATA is a MIME
entity.
(rmail-mime-bulk-handler): Just call rmail-mime-insert-bulk.
(rmail-mime-insert-bulk): New function mostly copied from the old
rmail-mime-bulk-handler.
(rmail-mime-multipart-handler): Just call
rmail-mime-process-multipart.
(rmail-mime-process-multipart): New funciton mostly copied from
the old rmail-mime-multipart-handler.
(rmail-mime-show): Just call rmail-mime-process.
(rmail-mime-process): New funciton mostly copied from the old
rmail-mime-show.
(rmail-mime-insert-multipart, rmail-mime-parse)
(rmail-mime-insert, rmail-show-mime)
(rmail-insert-mime-forwarded-message)
(rmail-insert-mime-resent-message): New functions.
(rmail-insert-mime-forwarded-message-function): Set to
rmail-insert-mime-forwarded-message.
(rmail-insert-mime-resent-message-function): Set to
rmail-insert-mime-resent-message.
* mail/rmailsum.el: Require rfc2047.
(rmail-header-summary): Handle multiline Subject: field.
(rmail-summary-line-decoder): Change the default to
rfc2047-decode-string.
* mail/rmail.el (rmail-enable-mime): Change the default to t.
(rmail-mime-feature): Change the default to `rmailmm'.
(rmail-quit): Delete the specifal code for rmail-enable-mime.
(rmail-display-labels): Likewise.
(rmail-show-message-1): Check rmail-enable-mime, and use
rmail-show-mime-function for a MIME message. Decode the headers
according to RFC2047.
2010-11-24 Stefan Monnier <monnier@iro.umontreal.ca>
* progmodes/which-func.el (which-func-imenu-joiner-function):
......
......@@ -638,7 +638,7 @@ Element N specifies the summary line for message N+1.")
This is set to nil by default.")
(defcustom rmail-enable-mime nil
(defcustom rmail-enable-mime t
"If non-nil, RMAIL uses MIME features.
If the value is t, RMAIL automatically shows MIME decoded message.
If 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."
:type '(choice (const :tag "on" t)
(const :tag "off" nil)
(other :tag "when asked" ask))
:version "23.3"
:group 'rmail)
(defvar rmail-enable-mime-composing nil
......@@ -693,13 +694,12 @@ start of the header) with three arguments MSG, REGEXP, and LIMIT,
where MSG is the message number, REGEXP is the regular
expression, LIMIT is the position specifying the end of header.")
(defvar rmail-mime-feature 'rmail-mime
(defvar rmail-mime-feature 'rmailmm
"Feature to require to load MIME support in Rmail.
When starting Rmail, if `rmail-enable-mime' is non-nil,
this feature is required with `require'.
The default value is `rmail-mime'. This feature is provided by
the rmail-mime package available at <http://www.m17n.org/rmail-mime/>.")
The default value is `rmailmm'")
;; FIXME this is unused.
(defvar rmail-decode-mime-charset t
......@@ -1509,17 +1509,9 @@ Hook `rmail-quit-hook' is run after expunging."
(set-buffer-modified-p nil))
(replace-buffer-in-windows rmail-summary-buffer)
(bury-buffer rmail-summary-buffer))
(if rmail-enable-mime
(let ((obuf rmail-buffer)
(ovbuf rmail-view-buffer))
(set-buffer rmail-view-buffer)
(quit-window)
(replace-buffer-in-windows ovbuf)
(replace-buffer-in-windows obuf)
(bury-buffer obuf))
(let ((obuf (current-buffer)))
(quit-window)
(replace-buffer-in-windows obuf))))
(let ((obuf (current-buffer)))
(quit-window)
(replace-buffer-in-windows obuf)))
(defun rmail-bury ()
"Bury current Rmail buffer and its summary buffer."
......@@ -2219,15 +2211,7 @@ If nil, that means the current message."
(let ((blurb (rmail-get-labels)))
(setq mode-line-process
(format " %d/%d%s"
rmail-current-message rmail-total-messages blurb))
;; If rmail-enable-mime is non-nil, we may have to update
;; `mode-line-process' of rmail-view-buffer too.
(if (and rmail-enable-mime
(not (eq (current-buffer) rmail-view-buffer))
(buffer-live-p rmail-view-buffer))
(let ((mlp mode-line-process))
(with-current-buffer rmail-view-buffer
(setq mode-line-process mlp))))))
rmail-current-message rmail-total-messages blurb))))
(defun rmail-get-attr-value (attr state)
"Return the character value for ATTR.
......@@ -2706,6 +2690,11 @@ The current mail message becomes the message displayed."
(message "Showing message %d" msg))
(narrow-to-region beg end)
(goto-char beg)
(if (and rmail-enable-mime
(re-search-forward "mime-version: 1.0" nil t))
(let ((rmail-buffer mbox-buf)
(rmail-view-buffer view-buf))
(funcall rmail-show-mime-function))
(setq body-start (search-forward "\n\n" nil t))
(narrow-to-region beg (point))
(goto-char beg)
......@@ -2722,11 +2711,6 @@ The current mail message becomes the message displayed."
;; unibyte temporary buffer where the character decoding takes
;; place.
(with-current-buffer rmail-view-buffer
;; We give the view buffer a buffer-local value of
;; rmail-header-style based on the binding in effect when
;; this function is called; `rmail-toggle-headers' can
;; inspect this value to determine how to toggle.
(set (make-local-variable 'rmail-header-style) header-style)
(erase-buffer))
(if (null character-coding)
;; Do it directly since that is fast.
......@@ -2749,8 +2733,13 @@ The current mail message becomes the message displayed."
(error "uuencoded messages are not supported yet"))
(t))
(rmail-decode-region (point-min) (point-max)
coding-system view-buf)))
coding-system view-buf))))
(with-current-buffer rmail-view-buffer
;; We give the view buffer a buffer-local value of
;; rmail-header-style based on the binding in effect when
;; this function is called; `rmail-toggle-headers' can
;; inspect this value to determine how to toggle.
(set (make-local-variable 'rmail-header-style) header-style)
;; Unquote quoted From lines
(goto-char (point-min))
(while (re-search-forward "^>+From " nil t)
......@@ -2766,6 +2755,10 @@ The current mail message becomes the message displayed."
(with-current-buffer rmail-view-buffer
(insert "\n")
(goto-char (point-min))
;; Decode the headers according to RFC2047.
(save-excursion
(search-forward "\n\n" nil 'move)
(rfc2047-decode-region (point-min) (point)))
(rmail-highlight-headers)
;(rmail-activate-urls)
;(rmail-process-quoted-material)
......
......@@ -26,17 +26,57 @@
;; Essentially based on the design of Alexander Pohoyda's MIME
;; extensions (mime-display.el and mime.el).
;; Call `M-x rmail-mime' when viewing an Rmail message.
;; This file provides two operation modes for viewing a MIME message.
;; (1) When rmail-enable-mime is non-nil (now it is the default), the
;; function `rmail-show-mime' is automatically called. That function
;; shows a MIME message directly in RMAIL's view buffer.
;; (2) When rmail-enable-mime is nil, the command 'v' (or M-x
;; rmail-mime) shows a MIME message in a new buffer "*RMAIL*".
;; Both operations share the intermediate functions rmail-mime-process
;; and rmail-mime-process-multipart as below.
;; rmail-show-mime
;; +- rmail-mime-parse
;; | +- rmail-mime-process <--+------------+
;; | | +---------+ |
;; | + rmail-mime-process-multipart --+
;; |
;; + rmail-mime-insert <----------------+
;; +- rmail-mime-insert-text |
;; +- rmail-mime-insert-bulk |
;; +- rmail-mime-insert-multipart --+
;;
;; rmail-mime
;; +- rmail-mime-show <----------------------------------+
;; +- rmail-mime-process |
;; +- rmail-mime-handle |
;; +- rmail-mime-text-handler |
;; +- rmail-mime-bulk-handler |
;; | + rmail-mime-insert-bulk
;; +- rmail-mime-multipart-handler |
;; +- rmail-mime-process-multipart --+
;; In addition, for the case of rmail-enable-mime being non-nil, this
;; file provides two functions rmail-insert-mime-forwarded-message and
;; rmail-insert-mime-resent-message for composing forwarded and resent
;; messages respectively.
;; Todo:
;; Handle multipart/alternative.
;; Make rmail-mime-media-type-handlers-alist usable in the first
;; operation mode.
;; Handle multipart/alternative in the second operation mode.
;; Offer the option to call external/internal viewers (doc-view, xpdf, etc).
;;; Code:
(require 'rmail)
(require 'mail-parse)
(require 'message)
;;; User options.
......@@ -90,6 +130,52 @@ automatically display the image in the buffer."
;;; End of user options.
;;; MIME-entity object
(defun rmail-mime-entity (type disposition transfer-encoding
header body children)
"Retrun a newly created MIME-entity object.
A MIME-entity is a vector of 6 elements:
[ TYPE DISPOSITION TRANSFER-ENCODING HEADER BODY CHILDREN ]
TYPE and DISPOSITION correspond to MIME headers Content-Type: and
Cotent-Disposition: respectively, and has this format:
\(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)
VALUE is a string and ATTRIBUTE is a symbol.
Consider the following header, for example:
Content-Type: multipart/mixed;
boundary=\"----=_NextPart_000_0104_01C617E4.BDEC4C40\"
The corresponding TYPE argument must be:
\(\"multipart/mixed\"
\(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))
TRANSFER-ENCODING corresponds to MIME header
Content-Transfer-Encoding, and is a lowercased string.
HEADER and BODY are a cons (BEG . END), where BEG and END specify
the region of the corresponding part in RMAIL's data (mbox)
buffer. BODY may be nil. In that case, the current buffer is
narrowed to the body part.
CHILDREN is a list of MIME-entities for a \"multipart\" entity, and
nil for the other types."
(vector type disposition transfer-encoding header body children))
;; Accessors for a MIME-entity object.
(defsubst rmail-mime-entity-type (entity) (aref entity 0))
(defsubst rmail-mime-entity-disposition (entity) (aref entity 1))
(defsubst rmail-mime-entity-transfer-encoding (entity) (aref entity 2))
(defsubst rmail-mime-entity-header (entity) (aref entity 3))
(defsubst rmail-mime-entity-body (entity) (aref entity 4))
(defsubst rmail-mime-entity-children (entity) (aref entity 5))
;;; Buttons
......@@ -98,6 +184,7 @@ automatically display the image in the buffer."
(let* ((filename (button-get button 'filename))
(directory (button-get button 'directory))
(data (button-get button 'data))
(mbox-buf rmail-view-buffer)
(ofilename filename))
(setq filename (expand-file-name
(read-file-name (format "Save as (default: %s): " filename)
......@@ -116,7 +203,17 @@ automatically display the image in the buffer."
;; file, the magic signature compares equal with the unibyte
;; signature string recorded in jka-compr-compression-info-list.
(set-buffer-multibyte nil)
(insert data)
(setq buffer-undo-list t)
(if (stringp data)
(insert data)
;; DATA is a MIME-entity object.
(let ((transfer-encoding (rmail-mime-entity-transfer-encoding data))
(body (rmail-mime-entity-body data)))
(insert-buffer-substring mbox-buf (car body) (cdr body))
(cond ((string= transfer-encoding "base64")
(ignore-errors (base64-decode-region (point-min) (point-max))))
((string= transfer-encoding "quoted-printable")
(quoted-printable-decode-region (point-min) (point-max))))))
(write-region nil nil filename nil nil nil t))))
(define-button-type 'rmail-mime-save 'action 'rmail-mime-save)
......@@ -133,6 +230,23 @@ automatically display the image in the buffer."
(when (coding-system-p coding-system)
(decode-coding-region (point-min) (point-max) coding-system))))
(defun rmail-mime-insert-text (entity)
"Insert MIME-entity ENTITY as a plain text MIME part in the current buffer."
(let* ((content-type (rmail-mime-entity-type entity))
(charset (cdr (assq 'charset (cdr content-type))))
(coding-system (if charset (intern (downcase charset))))
(transfer-encoding (rmail-mime-entity-transfer-encoding entity))
(body (rmail-mime-entity-body entity)))
(save-restriction
(narrow-to-region (point) (point))
(insert-buffer-substring rmail-buffer (car body) (cdr body))
(cond ((string= transfer-encoding "base64")
(ignore-errors (base64-decode-region (point-min) (point-max))))
((string= transfer-encoding "quoted-printable")
(quoted-printable-decode-region (point-min) (point-max))))
(if (coding-system-p coding-system)
(decode-coding-region (point-min) (point-max) coding-system)))))
;; FIXME move to the test/ directory?
(defun test-rmail-mime-handler ()
"Test of a mail using no MIME parts at all."
......@@ -151,10 +265,28 @@ MIME-Version: 1.0
(defun rmail-mime-insert-image (type data)
"Insert an image of type TYPE, where DATA is the image data."
"Insert an image of type TYPE, where DATA is the image data.
If DATA is not a string, it is a MIME-entity object."
(end-of-line)
(insert ?\n)
(insert-image (create-image data type t)))
(let ((modified (buffer-modified-p)))
(insert ?\n)
(unless (stringp data)
;; DATA is a MIME-entity.
(let ((transfer-encoding (rmail-mime-entity-transfer-encoding data))
(body (rmail-mime-entity-body data))
(mbox-buffer rmail-view-buffer))
(with-temp-buffer
(set-buffer-multibyte nil)
(setq buffer-undo-list t)
(insert-buffer-substring mbox-buffer (car body) (cdr body))
(cond ((string= transfer-encoding "base64")
(ignore-errors (base64-decode-region (point-min) (point-max))))
((string= transfer-encoding "quoted-printable")
(quoted-printable-decode-region (point-min) (point-max))))
(setq data
(buffer-substring-no-properties (point-min) (point-max))))))
(insert-image (create-image data type t))
(set-buffer-modified-p modified)))
(defun rmail-mime-image (button)
"Display the image associated with BUTTON."
......@@ -171,8 +303,19 @@ MIME-Version: 1.0
"Handle the current buffer as an attachment to download.
For images that Emacs is capable of displaying, the behavior
depends upon the value of `rmail-mime-show-images'."
(rmail-mime-insert-bulk
(rmail-mime-entity content-type content-disposition content-transfer-encoding
nil nil nil)))
(defun rmail-mime-insert-bulk (entity)
"Inesrt a MIME-entity ENTITY as an attachment.
The optional second arg DATA, if non-nil, is a string containing
the attachment data that is already decoded."
;; Find the default directory for this media type.
(let* ((directory (catch 'directory
(let* ((content-type (rmail-mime-entity-type entity))
(content-disposition (rmail-mime-entity-disposition entity))
(body (rmail-mime-entity-body entity))
(directory (catch 'directory
(dolist (entry rmail-mime-attachment-dirs-alist)
(when (string-match (car entry) (car content-type))
(dolist (dir (cdr entry))
......@@ -182,17 +325,21 @@ depends upon the value of `rmail-mime-show-images'."
(cdr (assq 'filename (cdr content-disposition)))
"noname"))
(label (format "\nAttached %s file: " (car content-type)))
(data (buffer-string))
(udata (string-as-unibyte data))
(size (length udata))
(osize size)
(units '(B kB MB GB))
type)
(while (and (> size 1024.0) ; cribbed from gnus-agent-expire-done-message
data udata size osize type)
(if body
(setq data entity
udata entity
size (- (cdr body) (car body)))
(setq data (buffer-string)
udata (string-as-unibyte data)
size (length udata))
(delete-region (point-min) (point-max)))
(setq osize size)
(while (and (> size 1024.0) ; cribbed from gnus-agent-expire-done-message
(cdr units))
(setq size (/ size 1024.0)
units (cdr units)))
(delete-region (point-min) (point-max))
(insert label)
(insert-button filename
:type 'rmail-mime-save
......@@ -248,6 +395,22 @@ The current buffer should be narrowed to the body. CONTENT-TYPE,
CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values
of the respective parsed headers. See `rmail-mime-handle' for their
format."
(rmail-mime-process-multipart
content-type content-disposition content-transfer-encoding nil))
(defun rmail-mime-process-multipart (content-type
content-disposition
content-transfer-encoding
parse-only)
"Process the current buffer as a multipart MIME body.
If PARSE-ONLY is nil, modify the current buffer directly for showing
the MIME body and return nil.
Otherwise, just parse the current buffer and return a list of
MIME-entity objects.
The other arguments are the same as `rmail-mime-multipart-handler'."
;; Some MUAs start boundaries with "--", while it should start
;; with "CRLF--", as defined by RFC 2046:
;; The boundary delimiter MUST occur at the beginning of a line,
......@@ -256,7 +419,7 @@ format."
;; of the preceding part.
;; We currently don't handle that.
(let ((boundary (cdr (assq 'boundary content-type)))
beg end next)
beg end next entities)
(unless boundary
(rmail-mm-get-boundary-error-message
"No boundary defined" content-type content-disposition
......@@ -266,7 +429,9 @@ format."
(goto-char (point-min))
(when (and (search-forward boundary nil t)
(looking-at "[ \t]*\n"))
(delete-region (point-min) (match-end 0)))
(if parse-only
(narrow-to-region (match-end 0) (point-max))
(delete-region (point-min) (match-end 0))))
;; Loop over all body parts, where beg points at the beginning of
;; the part and end points at the end of the part. next points at
;; the beginning of the next part.
......@@ -284,13 +449,17 @@ format."
(rmail-mm-get-boundary-error-message
"Malformed boundary" content-type content-disposition
content-transfer-encoding)))
(delete-region end next)
;; Handle the part.
(save-restriction
(narrow-to-region beg end)
(rmail-mime-show))
(goto-char (setq beg next)))))
(if parse-only
(save-restriction
(narrow-to-region beg end)
(setq entities (cons (rmail-mime-process nil t) entities)))
(delete-region end next)
(save-restriction
(narrow-to-region beg end)
(rmail-mime-show)))
(goto-char (setq beg next)))
(nreverse entities)))
(defun test-rmail-mime-multipart-handler ()
"Test of a mail used as an example in RFC 2046."
......@@ -393,6 +562,9 @@ called recursively if multiple parts are available.
The current buffer must contain a single message. It will be
modified."
(rmail-mime-process show-headers nil))
(defun rmail-mime-process (show-headers parse-only)
(let ((end (point-min))
content-type
content-transfer-encoding
......@@ -436,14 +608,105 @@ modified."
;; attachment according to RFC 2183.
(unless (member (car content-disposition) '("inline" "attachment"))
(setq content-disposition '("attachment")))
;; Hide headers and handle the part.
(save-restriction
(cond ((string= (car content-type) "message/rfc822")
(narrow-to-region end (point-max)))
((not show-headers)
(delete-region (point-min) end)))
(rmail-mime-handle content-type content-disposition
content-transfer-encoding))))
(if parse-only
(cond ((string-match "multipart/.*" (car content-type))
(setq end (1- end))
(save-restriction
(let ((header (if show-headers (cons (point-min) end))))
(narrow-to-region end (point-max))
(rmail-mime-entity content-type
content-disposition
content-transfer-encoding
header nil
(rmail-mime-process-multipart
content-type content-disposition
content-transfer-encoding t)))))
((string-match "message/rfc822" (car content-type))
(or show-headers
(narrow-to-region end (point-max)))
(rmail-mime-process t t))
(t
(rmail-mime-entity content-type
content-disposition
content-transfer-encoding
nil
(cons end (point-max))
nil)))
;; Hide headers and handle the part.
(save-restriction
(cond ((string= (car content-type) "message/rfc822")
(narrow-to-region end (point-max)))
((not show-headers)
(delete-region (point-min) end)))
(rmail-mime-handle content-type content-disposition
content-transfer-encoding)))))
(defun rmail-mime-insert-multipart (entity)
"Insert MIME-entity ENTITY of multipart type in the current buffer."
(let ((subtype (cadr (split-string (car (rmail-mime-entity-type entity))
"/")))
(disposition (rmail-mime-entity-disposition entity))
(header (rmail-mime-entity-header entity))
(children (rmail-mime-entity-children entity)))
(if header
(let ((pos (point)))
(or (bolp)
(insert "\n"))
(insert-buffer-substring rmail-buffer (car header) (cdr header))
(rfc2047-decode-region pos (point))
(insert "\n")))
(cond
((string= subtype "mixed")
(dolist (child children)
(rmail-mime-insert child '("text/plain") disposition)))
((string= subtype "digest")
(dolist (child children)
(rmail-mime-insert child '("message/rfc822") disposition)))
((string= subtype "alternative")
(let (best-plain-text best-text)
(dolist (child children)
(if (string= (or (car (rmail-mime-entity-disposition child))
(car disposition))
"inline")
(if (string-match "text/plain"
(car (rmail-mime-entity-type child)))
(setq best-plain-text child)
(if (string-match "text/.*"
(car (rmail-mime-entity-type child)))
(setq best-text child)))))
(if (or best-plain-text best-text)
(rmail-mime-insert (or best-plain-text best-text))
;; No child could be handled. Insert all.
(dolist (child children)
(rmail-mime-insert child nil disposition)))))
(t
;; Unsupported subtype. Insert all as attachment.
(dolist (child children)
(rmail-mime-insert-bulk child))))))
(defun rmail-mime-parse ()
"Parse the current Rmail message as a MIME message.
The value is a MIME-entiy object (see `rmail-mime-enty-new')."
(save-excursion
(goto-char (point-min))
(rmail-mime-process nil t)))
(defun rmail-mime-insert (entity &optional content-type disposition)
"Insert a MIME-entity ENTITY in the current buffer.
This function will be called recursively if multiple parts are
available."
(if (rmail-mime-entity-children entity)
(rmail-mime-insert-multipart entity)
(setq content-type
(or (rmail-mime-entity-type entity) content-type))
(setq disposition
(or (rmail-mime-entity-disposition entity) disposition))
(if (and (string= (car disposition) "inline")
(string-match "text/.*" (car content-type)))
(rmail-mime-insert-text entity)
(rmail-mime-insert-bulk entity))))
(define-derived-mode rmail-mime-mode fundamental-mode "RMIME"
"Major mode used in `rmail-mime' buffers."
......@@ -479,6 +742,50 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'."
(error "%s; type: %s; disposition: %s; encoding: %s"
message type disposition encoding))
(defun rmail-show-mime ()
(let ((mbox-buf rmail-buffer))
(condition-case nil
(let ((entity (rmail-mime-parse)))
(with-current-buffer rmail-view-buffer
(let ((inhibit-read-only t)
(rmail-buffer mbox-buf))
(erase-buffer)
(rmail-mime-insert entity))))
(error
;; Decoding failed. Insert the original message body as is.
(let ((region (with-current-buffer mbox-buf
(goto-char (point-min))
(re-search-forward "^$" nil t)
(forward-line 1)
(cons (point) (point-max)))))
(with-current-buffer rmail-view-buffer
(let ((inhibit-read-only t))
(erase-buffer)
(insert-buffer-substring mbox-buf (car region) (cdr region))))
(message "MIME decoding failed"))))))
(setq rmail-show-mime-function 'rmail-show-mime)
(defun rmail-insert-mime-forwarded-message (forward-buffer)
(let ((mbox-buf (with-current-buffer forward-buffer rmail-view-buffer)))
(save-restriction
(narrow-to-region (point) (point))
(message-forward-make-body-mime mbox-buf))))
(setq rmail-insert-mime-forwarded-message-function
'rmail-insert-mime-forwarded-message)
(defun rmail-insert-mime-resent-message (forward-buffer)