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
: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
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
(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."
(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.
(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)
;; 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.
(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)
(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)
;; 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.
;;; 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
(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)
;; 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)
(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."
(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."
"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))
(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
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,
;; 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
(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.
(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."
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
;; 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."
(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)
+ (insert-buffer-substring
+ (with-current-buffer forward-buffer rmail-view-buffer))
+ (goto-char (point-min))
+ (when (looking-at "From ")
+ (forward-line 1)
+ (delete-region (point-min) (point))))
+
+(setq rmail-insert-mime-resent-message-function
+ 'rmail-insert-mime-resent-message)
+
(provide 'rmailmm)
;; Local Variables:
HCoop / bpt / emacs.git / commitdiff