;;; rmailmm.el --- MIME decoding and display stuff for RMAIL
-;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2016 Free Software Foundation, Inc.
;; Author: Alexander Pohoyda
;; Alex Schroeder
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: mail
;; Package: rmail
:version "23.2"
:group 'rmail-mime)
+(defcustom rmail-mime-render-html-function
+ (cond ((fboundp 'libxml-parse-html-region) 'rmail-mime-render-html-shr)
+ ((executable-find "lynx") 'rmail-mime-render-html-lynx)
+ (t nil))
+ "Function to convert HTML to text.
+Called with buffer containing HTML extracted from message in a
+temporary buffer. Converts to text in current buffer. If nil,
+display HTML source."
+ :group 'rmail
+ :version "25.1"
+ :type '(choice function (const nil)))
+
+(defcustom rmail-mime-prefer-html
+ ;; Default to preferring HTML parts, but only if we have a renderer
+ (if rmail-mime-render-html-function t nil)
+ "If non-nil, default to showing HTML part rather than text part
+when both are available"
+ :group 'rmail
+ :version "25.1"
+ :type 'boolean)
+
;;; End of user options.
;;; Global variables that always have let-binding when referred.
The value is usually nil, and bound to non-nil while inserting
MIME entities.")
+(defvar rmail-mime-searching nil
+ "Bound to T inside `rmail-search-mime-message' to suppress expensive
+operations such as HTML decoding")
+
;;; MIME-entity object
(defun rmail-mime-entity (type disposition transfer-encoding
- display header tagline body children handler)
- "Retrun a newly created MIME-entity object from arguments.
+ display header tagline body children handler
+ &optional truncated)
+ "Return a newly created MIME-entity object from arguments.
-A MIME-entity is a vector of 9 elements:
+A MIME-entity is a vector of 10 elements:
[TYPE DISPOSITION TRANSFER-ENCODING DISPLAY HEADER TAGLINE BODY
- CHILDREN HANDLER]
+ CHILDREN HANDLER TRUNCATED]
TYPE and DISPOSITION correspond to MIME headers Content-Type and
-Cotent-Disposition respectively, and has this format:
+Content-Disposition respectively, and have this format:
- \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)
+ (VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)
-VALUE is a string and ATTRIBUTE is a symbol.
+Each VALUE is a string and each ATTRIBUTE is a string.
Consider the following header, for example:
The corresponding TYPE argument must be:
\(\"multipart/mixed\"
- \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))
+ (\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))
TRANSFER-ENCODING corresponds to MIME header
-Content-Transfer-Encoding, and is a lowercased string.
+Content-Transfer-Encoding, and is a lower-case string.
DISPLAY is a vector [CURRENT NEW], where CURRENT indicates how
-the header, tagline, and body of the entity are displayed now,
-and NEW indicates how their displaying should be updated.
-Both elements are vector [HEADER-DISPLAY TAGLINE-DISPLAY BODY-DISPLAY],
-where each element is a symbol for the corresponding item that
-has these values:
+the header, tag line, and body of the entity are displayed now,
+and NEW indicates how their display should be updated.
+Both elements are vectors [HEADER-DISPLAY TAGLINE-DISPLAY BODY-DISPLAY],
+where each constituent element is a symbol for the corresponding
+item with these values:
nil: not displayed
- t: displayed by the decoded presentation form
+ t: displayed by the decoded presentation form
raw: displayed by the raw MIME data (for the header and body only)
HEADER and BODY are vectors [BEG END DISPLAY-FLAG], where BEG and
-END specify the region of the header or body lines in RMAIL's
-data (mbox) buffer, and DISPLAY-FLAG non-nil means that the
+END are markers that specify the region of the header or body lines
+in RMAIL's data (mbox) buffer, and DISPLAY-FLAG non-nil means that the
header or body is, by default, displayed by the decoded
presentation form.
TAGLINE is a vector [TAG BULK-DATA DISPLAY-FLAG], where TAG is a
string indicating the depth and index number of the entity,
BULK-DATA is a cons (SIZE . TYPE) indicating the size and type of
-an attached data, DISPLAY-FLAG non-nil means that the tagline is,
-by default, displayed.
+an attached data, DISPLAY-FLAG non-nil means that the tag line is
+displayed by default.
CHILDREN is a list of child MIME-entities. A \"multipart/*\"
-entity have one or more children. A \"message/rfc822\" entity
+entity has one or more children. A \"message/rfc822\" entity
has just one child. Any other entity has no child.
HANDLER is a function to insert the entity according to DISPLAY.
-It is called with one argument ENTITY."
+It is called with one argument ENTITY.
+
+TRUNCATED is non-nil if the text of this entity was truncated."
+
(vector type disposition transfer-encoding
- display header tagline body children handler))
+ display header tagline body children handler truncated))
;; Accessors for a MIME-entity object.
(defsubst rmail-mime-entity-type (entity) (aref entity 0))
(defsubst rmail-mime-entity-body (entity) (aref entity 6))
(defsubst rmail-mime-entity-children (entity) (aref entity 7))
(defsubst rmail-mime-entity-handler (entity) (aref entity 8))
-
-(defsubst rmail-mime-message-p ()
- "Non-nil if and only if the current message is a MIME."
- (or (get-text-property (point) 'rmail-mime-entity)
- (get-text-property (point-min) 'rmail-mime-entity)))
+(defsubst rmail-mime-entity-truncated (entity) (aref entity 9))
+(defsubst rmail-mime-entity-set-truncated (entity truncated)
+ (aset entity 9 truncated))
;;; Buttons
(directory (button-get button 'directory))
(data (button-get button 'data))
(ofilename filename))
+ (if (and (not (stringp data))
+ (rmail-mime-entity-truncated data))
+ (unless (y-or-n-p "This entity is truncated; save anyway? ")
+ (error "Aborted")))
(setq filename (expand-file-name
(read-file-name (format "Save as (default: %s): " filename)
directory
(define-button-type 'rmail-mime-save 'action 'rmail-mime-save)
+;; Display options returned by rmail-mime-entity-display.
+;; Value is on of nil, t, raw.
+(defsubst rmail-mime-display-header (disp) (aref disp 0))
+(defsubst rmail-mime-display-tagline (disp) (aref disp 1))
+(defsubst rmail-mime-display-body (disp) (aref disp 2))
+
(defun rmail-mime-entity-segment (pos &optional entity)
"Return a vector describing the displayed region of a MIME-entity at POS.
Optional 2nd argument ENTITY is the MIME-entity at POS.
-The value is a vector [ INDEX HEADER TAGLINE BODY END], where
- INDEX: index into the returned vector indicating where POS is (1..3).
+The value is a vector [INDEX HEADER TAGLINE BODY END], where
+ INDEX: index into the returned vector indicating where POS is (1..3)
HEADER: the position of the beginning of a header
- TAGLINE: the position of the beginning of a tagline
+ TAGLINE: the position of the beginning of a tag line, including
+ the newline that precedes it
BODY: the position of the beginning of a body
END: the position of the end of the entity."
(save-excursion
(index 1)
tagline-beg body-beg end)
(goto-char beg)
- (if (aref current 0)
+ ;; If the header is displayed, get past it to the tagline.
+ (if (rmail-mime-display-header current)
(search-forward "\n\n" nil t))
(setq tagline-beg (point))
(if (>= pos tagline-beg)
(setq index 2))
- (if (aref current 1)
- (forward-line 1))
+ ;; If the tagline is displayed, get past it to the body.
+ (if (rmail-mime-display-tagline current)
+ ;; The next forward-line call must be in sync with how
+ ;; `rmail-mime-insert-tagline' formats the tagline. The
+ ;; body begins after the empty line that ends the tagline.
+ (forward-line 3))
(setq body-beg (point))
(if (>= pos body-beg)
(setq index 3))
- (if (aref current 2)
+ ;; If the body is displayed, find its end.
+ (if (rmail-mime-display-body current)
(let ((tag (aref (rmail-mime-entity-tagline entity) 0))
tag2)
(setq end (next-single-property-change beg 'rmail-mime-entity
nil (point-max)))
+ ;; `tag' is either an empty string or "/n" where n is
+ ;; the number of the part of the multipart MIME message.
+ ;; The loop below finds the next location whose
+ ;; `rmail-mime-entity' property specifies a tag of a
+ ;; different value.
(while (and (< end (point-max))
(setq entity (get-text-property end 'rmail-mime-entity)
tag2 (aref (rmail-mime-entity-tagline entity) 0))
(vector index beg tagline-beg body-beg end)))))
(defun rmail-mime-shown-mode (entity)
- "Make MIME-entity ENTITY displayed by the default way."
+ "Make MIME-entity ENTITY display in the default way."
(let ((new (aref (rmail-mime-entity-display entity) 1)))
(aset new 0 (aref (rmail-mime-entity-header entity) 2))
(aset new 1 (aref (rmail-mime-entity-tagline entity) 2))
(rmail-mime-shown-mode child)))
(defun rmail-mime-hidden-mode (entity)
- "Make MIME-entity ENTITY displayed in the hidden mode."
+ "Make MIME-entity ENTITY display in hidden mode."
(let ((new (aref (rmail-mime-entity-display entity) 1)))
(aset new 0 nil)
(aset new 1 t)
(rmail-mime-hidden-mode child)))
(defun rmail-mime-raw-mode (entity)
- "Make MIME-entity ENTITY displayed in the raw mode."
+ "Make MIME-entity ENTITY display in raw mode."
(let ((new (aref (rmail-mime-entity-display entity) 1)))
(aset new 0 'raw)
(aset new 1 nil)
(dolist (child (rmail-mime-entity-children entity))
(rmail-mime-raw-mode child)))
-(defun rmail-mime-toggle-raw (entity)
- "Toggle on and off the raw display mode of MIME-entity ENTITY."
+(defun rmail-mime-toggle-raw (&optional state)
+ "Toggle on and off the raw display mode of MIME-entity at point.
+With optional argument STATE, force the specified display mode.
+Use `raw' for raw mode, and any other non-nil value for decoded mode."
(let* ((pos (if (eobp) (1- (point-max)) (point)))
(entity (get-text-property pos 'rmail-mime-entity))
(current (aref (rmail-mime-entity-display entity) 0))
(segment (rmail-mime-entity-segment pos entity)))
- (if (not (eq (aref current 0) 'raw))
+ (if (or (eq state 'raw)
+ (and (not state)
+ (not (eq (rmail-mime-display-header current) 'raw))))
;; Enter the raw mode.
(rmail-mime-raw-mode entity)
;; Enter the shown mode.
- (rmail-mime-shown-mode entity))
- (let ((inhibit-read-only t)
- (modified (buffer-modified-p)))
- (save-excursion
- (goto-char (aref segment 1))
- (rmail-mime-insert entity)
- (restore-buffer-modified-p modified)))))
+ (rmail-mime-shown-mode entity)
+ (let ((inhibit-read-only t)
+ (modified (buffer-modified-p)))
+ (save-excursion
+ (goto-char (aref segment 1))
+ (rmail-mime-insert entity)
+ (restore-buffer-modified-p modified))))))
(defun rmail-mime-toggle-hidden ()
- "Hide or show the body of MIME-entity at point."
+ "Hide or show the body of the MIME-entity at point."
(interactive)
(when (rmail-mime-message-p)
(let* ((rmail-mime-mbox-buffer rmail-view-buffer)
(entity (get-text-property pos 'rmail-mime-entity))
(current (aref (rmail-mime-entity-display entity) 0))
(segment (rmail-mime-entity-segment pos entity)))
- (if (aref current 2)
+ (if (rmail-mime-display-body current)
;; Enter the hidden mode.
(progn
;; If point is in the body part, move it to the tagline
(if (and rmail-mime-mbox-buffer (= (aref segment 1) (point-min)))
(let ((new (aref (rmail-mime-entity-display entity) 1)))
(aset new 0 t))))
+ ;; Query as a warning before showing if truncated.
+ (if (and (not (stringp entity))
+ (rmail-mime-entity-truncated entity))
+ (unless (y-or-n-p "This entity is truncated; show anyway? ")
+ (error "Aborted")))
;; Enter the shown mode.
(rmail-mime-shown-mode entity)
;; Force this body shown.
(defun rmail-mime-insert-tagline (entity &rest item-list)
"Insert a tag line for MIME-entity ENTITY.
-ITEM-LIST is a list of strings or button-elements (list) to be added
+ITEM-LIST is a list of strings or button-elements (list) to add
to the tag line."
- (insert "[")
+ ;; Precede the tagline by an empty line to make it a separate
+ ;; paragraph, so that it is aligned to the left margin of the window
+ ;; even if preceded by a right-to-left paragraph.
+ (insert "\n[")
(let ((tag (aref (rmail-mime-entity-tagline entity) 0)))
(if (> (length tag) 0) (insert (substring tag 1) ":")))
(insert (car (rmail-mime-entity-type entity)) " ")
(insert-button (let ((new (aref (rmail-mime-entity-display entity) 1)))
- (if (aref new 2) "Hide" "Show"))
+ (if (rmail-mime-display-body new) "Hide" "Show"))
:type 'rmail-mime-toggle
'help-echo "mouse-2, RET: Toggle show/hide")
(dolist (item item-list)
(if (stringp item)
(insert item)
(apply 'insert-button item))))
- (insert "]\n"))
+ ;; Follow the tagline by an empty line to make it a separate
+ ;; paragraph, so that the paragraph direction of the following text
+ ;; is determined based on that text.
+ (insert "]\n\n"))
(defun rmail-mime-update-tagline (entity)
"Update the current tag line for MIME-entity ENTITY."
(delete-region (button-start button) (point))
(put-text-property (point) (button-end button) 'rmail-mime-entity entity)
(restore-buffer-modified-p modified)
- (forward-line 1)))
+ ;; The following call to forward-line must be in sync with how
+ ;; rmail-mime-insert-tagline formats the tagline.
+ (forward-line 2)))
(defun rmail-mime-insert-header (header)
"Decode and insert a MIME-entity header HEADER in the current buffer.
HEADER is a vector [BEG END DEFAULT-STATUS].
-See `rmail-mime-entity' for the detail."
+See `rmail-mime-entity' for details."
(let ((pos (point))
(last-coding-system-used nil))
(save-restriction
(insert "\n"))))
(defun rmail-mime-find-header-encoding (header)
- "Retun the last coding system used to decode HEADER.
+ "Return the last coding system used to decode HEADER.
HEADER is a header component of a MIME-entity object (see
`rmail-mime-entity')."
(with-temp-buffer
(beg (point))
(segment (rmail-mime-entity-segment (point) entity)))
- (or (integerp (aref body 0))
+ (or (integerp (aref body 0)) (markerp (aref body 0))
(let ((data (buffer-string)))
(aset body 0 data)
(delete-region (point-min) (point-max))))
;; header
- (if (eq (aref current 0) (aref new 0))
+ (if (eq (rmail-mime-display-header current)
+ (rmail-mime-display-header new))
(goto-char (aref segment 2))
- (if (aref current 0)
+ (if (rmail-mime-display-header current)
(delete-char (- (aref segment 2) (aref segment 1))))
- (if (aref new 0)
+ (if (rmail-mime-display-header new)
(rmail-mime-insert-header header)))
;; tagline
- (if (eq (aref current 1) (aref new 1))
- (if (or (not (aref current 1))
- (eq (aref current 2) (aref new 2)))
+ (if (eq (rmail-mime-display-tagline current)
+ (rmail-mime-display-tagline new))
+ (if (or (not (rmail-mime-display-tagline current))
+ (eq (rmail-mime-display-body current)
+ (rmail-mime-display-body new)))
(forward-char (- (aref segment 3) (aref segment 2)))
(rmail-mime-update-tagline entity))
- (if (aref current 1)
+ (if (rmail-mime-display-tagline current)
(delete-char (- (aref segment 3) (aref segment 2))))
- (if (aref new 1)
+ (if (rmail-mime-display-tagline new)
(rmail-mime-insert-tagline entity)))
;; body
- (if (eq (aref current 2) (aref new 2))
+ (if (eq (rmail-mime-display-body current)
+ (rmail-mime-display-body new))
(forward-char (- (aref segment 4) (aref segment 3)))
- (if (aref current 2)
+ (if (rmail-mime-display-body current)
(delete-char (- (aref segment 4) (aref segment 3))))
- (if (aref new 2)
+ (if (rmail-mime-display-body new)
(rmail-mime-insert-decoded-text entity)))
(put-text-property beg (point) 'rmail-mime-entity entity)))
-;; FIXME move to the test/ directory?
-(defun test-rmail-mime-handler ()
- "Test of a mail using no MIME parts at all."
- (let ((mail "To: alex@gnu.org
-Content-Type: text/plain; charset=koi8-r
-Content-Transfer-Encoding: 8bit
-MIME-Version: 1.0
-
-\372\304\322\301\327\323\324\327\325\312\324\305\41"))
- (switch-to-buffer (get-buffer-create "*test*"))
- (erase-buffer)
- (set-buffer-multibyte nil)
- (insert mail)
- (rmail-mime-show t)
- (set-buffer-multibyte t)))
-
-
(defun rmail-mime-insert-image (entity)
"Decode and insert the image body of MIME-entity ENTITY."
(let* ((content-type (car (rmail-mime-entity-type entity)))
(insert-image (create-image data (cdr bulk-data) t))
(insert "\n")))
+(defun rmail-mime-insert-html (entity)
+ "Decode, render, and insert html from MIME-entity ENTITY."
+ (let ((body (rmail-mime-entity-body entity))
+ (transfer-encoding (rmail-mime-entity-transfer-encoding entity))
+ (charset (cdr (assq 'charset (cdr (rmail-mime-entity-type entity)))))
+ (buffer (current-buffer))
+ (case-fold-search t)
+ coding-system)
+ (if charset (setq coding-system (coding-system-from-name charset)))
+ (or (and coding-system (coding-system-p coding-system))
+ (setq coding-system 'undecided))
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (setq buffer-undo-list t)
+ (insert-buffer-substring rmail-mime-mbox-buffer
+ (aref body 0) (aref body 1))
+ (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))))
+ ;; Some broken MUAs state the charset only in the HTML <head>,
+ ;; so if we don't have a non-trivial coding-system at this
+ ;; point, make one last attempt to find it there.
+ (if (eq coding-system 'undecided)
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward
+ "^<html><head><meta[^;]*; charset=\\([-a-zA-Z0-9]+\\)"
+ nil t)
+ (setq coding-system (coding-system-from-name (match-string 1)))
+ (or (and coding-system (coding-system-p coding-system))
+ (setq coding-system 'undecided)))
+ ;; Finally, let them manually force decoding if they know it.
+ (if (and (eq coding-system 'undecided)
+ (not (null coding-system-for-read)))
+ (setq coding-system coding-system-for-read))))
+ (decode-coding-region (point-min) (point) coding-system)
+ (if (and
+ (or (not rmail-mime-coding-system) (consp rmail-mime-coding-system))
+ (not (eq (coding-system-base coding-system) 'us-ascii)))
+ (setq rmail-mime-coding-system coding-system))
+ ;; Convert html in temporary buffer to text and insert in original buffer
+ (let ((source-buffer (current-buffer)))
+ (with-current-buffer buffer
+ (let ((start (point)))
+ (if rmail-mime-render-html-function
+ (funcall rmail-mime-render-html-function source-buffer)
+ (insert-buffer-substring source-buffer))
+ (rmail-mime-fix-inserted-faces start)))))))
+
+(declare-function libxml-parse-html-region "xml.c"
+ (start end &optional base-url discard-comments))
+
+(defun rmail-mime-render-html-shr (source-buffer)
+ (let ((dom (with-current-buffer source-buffer
+ (libxml-parse-html-region (point-min) (point-max))))
+ ;; Image retrieval happens asynchronously, but meanwhile
+ ;; `rmail-swap-buffers' may have been run, leaving
+ ;; `shr-image-fetched' trying to insert the image in the wrong buffer.
+ (shr-inhibit-images t)
+ ;; Bind shr-width to nil to force shr-insert-document break
+ ;; the lines at the window margin. The default is
+ ;; fill-column, whose default value is too small, and screws
+ ;; up display of the quoted messages.
+ shr-width)
+ (shr-insert-document dom)))
+
+(defun rmail-mime-render-html-lynx (source-buffer)
+ (let ((destination-buffer (current-buffer)))
+ (with-current-buffer source-buffer
+ (call-process-region (point-min) (point-max)
+ "lynx" nil destination-buffer nil
+ "-stdin" "-dump" "-force_html"
+ "-dont_wrap_pre" "-width=70"))))
+
+;; Put font-lock-face properties matching face properties on text
+;; inserted, e.g., by shr, in text from START to point.
+(defun rmail-mime-fix-inserted-faces (start)
+ (while (< start (point))
+ (let ((face (get-text-property start 'face))
+ (next (next-single-property-change
+ start 'face (current-buffer) (point))))
+ (if face ; anything to do?
+ (put-text-property start next 'font-lock-face face))
+ (setq start next))))
+
(defun rmail-mime-toggle-button (button)
"Hide or show the body of the MIME-entity associated with BUTTON."
(save-excursion
(setq size (/ (* size 7) 3)))))))
(cond
+ ((string-match "text/html" content-type)
+ (setq type 'html))
((string-match "text/" content-type)
(setq type 'text))
((string-match "image/\\(.*\\)" content-type)
(setq type (image-type-from-file-name
(concat "." (match-string 1 content-type))))
- (if (and (memq type image-types)
+ (if (and (boundp 'image-types)
+ (memq type image-types)
(image-type-available-p type))
(if (and rmail-mime-show-images
(not (eq rmail-mime-show-images 'button))
(segment (rmail-mime-entity-segment (point) entity))
beg data size)
- (if (integerp (aref body 0))
+ (if (or (integerp (aref body 0)) (markerp (aref body 0)))
(setq data entity
size (car bulk-data))
(if (stringp (aref body 0))
(setq beg (point))
;; header
- (if (eq (aref current 0) (aref new 0))
+ (if (eq (rmail-mime-display-header current)
+ (rmail-mime-display-header new))
(goto-char (aref segment 2))
- (if (aref current 0)
+ (if (rmail-mime-display-header current)
(delete-char (- (aref segment 2) (aref segment 1))))
- (if (aref new 0)
+ (if (rmail-mime-display-header new)
(rmail-mime-insert-header header)))
;; tagline
- (if (eq (aref current 1) (aref new 1))
- (if (or (not (aref current 1))
- (eq (aref current 2) (aref new 2)))
+ (if (eq (rmail-mime-display-tagline current)
+ (rmail-mime-display-tagline new))
+ (if (or (not (rmail-mime-display-tagline current))
+ (eq (rmail-mime-display-body current)
+ (rmail-mime-display-body new)))
(forward-char (- (aref segment 3) (aref segment 2)))
(rmail-mime-update-tagline entity))
- (if (aref current 1)
+ (if (rmail-mime-display-tagline current)
(delete-char (- (aref segment 3) (aref segment 2))))
- (if (aref new 1)
+ (if (rmail-mime-display-tagline new)
(rmail-mime-insert-tagline
entity
" Save:"
;; 'image-data data))
)))
;; body
- (if (eq (aref current 2) (aref new 2))
+ (if (eq (rmail-mime-display-body current)
+ (rmail-mime-display-body new))
(forward-char (- (aref segment 4) (aref segment 3)))
- (if (aref current 2)
+ (if (rmail-mime-display-body current)
(delete-char (- (aref segment 4) (aref segment 3))))
- (if (aref new 2)
+ (if (rmail-mime-display-body new)
(cond ((eq (cdr bulk-data) 'text)
(rmail-mime-insert-decoded-text entity))
+ ((eq (cdr bulk-data) 'html)
+ ;; Render HTML if display single message, but if searching
+ ;; don't render but just search HTML itself.
+ (if rmail-mime-searching
+ (rmail-mime-insert-decoded-text entity)
+ (rmail-mime-insert-html entity)))
((cdr bulk-data)
(rmail-mime-insert-image entity))
(t
(rmail-mime-insert-decoded-text entity)))))
(put-text-property beg (point) 'rmail-mime-entity entity)))
-(defun test-rmail-mime-bulk-handler ()
- "Test of a mail used as an example in RFC 2183."
- (let ((mail "Content-Type: image/jpeg
-Content-Disposition: attachment; filename=genome.jpeg;
- modification-date=\"Wed, 12 Feb 1997 16:29:51 -0500\";
-Content-Description: a complete map of the human genome
-Content-Transfer-Encoding: base64
-
-iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAMAAABg3Am1AAAABGdBTUEAALGPC/xhBQAAAAZQ
-TFRF////AAAAVcLTfgAAAPZJREFUeNq9ldsOwzAIQ+3//+l1WlvA5ZLsoUiTto4TB+ISoAjy
-+ITfRBfcAmgRFFeAm+J6uhdKdFhFWUgDkFsK0oUp/9G2//Kj7Jx+5tSKOdBscgUYiKHRS/me
-WATQdRUvAK0Bnmshmtn79PpaLBbbOZkjKvRnjRZoRswOkG1wFchKew2g9wXVJVZL/m4+B+vv
-9AxQQR2Q33SgAYJzzVACdAWjAfRYzYFO9n6SLnydtQHSMxYDMAKqZ/8FS/lTK+zuq3CtK64L
-UDwbgUEAUmk2Zyg101d6PhCDySgAvTvDgKiuOrc4dLxUb7UMnhGIexyI+d6U+ABuNAP4Simx
-lgAAAABJRU5ErkJggg==
-"))
- (switch-to-buffer (get-buffer-create "*test*"))
- (erase-buffer)
- (insert mail)
- (rmail-mime-show)))
-
(defun rmail-mime-multipart-handler (content-type
content-disposition
content-transfer-encoding)
(let ((boundary (cdr (assq 'boundary content-type)))
(subtype (cadr (split-string (car content-type) "/")))
(index 0)
- beg end next entities)
+ beg end next entities truncated last)
(unless boundary
(rmail-mm-get-boundary-error-message
"No boundary defined" content-type content-disposition
;; the beginning of the next part. The current point is just
;; after the boundary tag.
(setq beg (point-min))
- (while (search-forward boundary nil t)
- (setq end (match-beginning 0))
+
+ (while (or (and (search-forward boundary nil t)
+ (setq truncated nil end (match-beginning 0)))
+ ;; If the boundary does not appear at all,
+ ;; the message was truncated.
+ ;; Handle the rest of the truncated message
+ ;; (if it isn't empty) by pretending that the boundary
+ ;; appears at the end of the message.
+ ;; We use `last' to distinguish this from the more
+ ;; likely situation of there being an epilogue
+ ;; after the last boundary, which should be ignored.
+ ;; See rmailmm-test-multipart-handler for an example,
+ ;; and also bug#10101.
+ (and (not last)
+ (save-excursion
+ (skip-chars-forward "\n")
+ (> (point-max) (point)))
+ (setq truncated t end (point-max))))
;; If this is the last boundary according to RFC 2046, hide the
;; epilogue, else hide the boundary only. Use a marker for
;; `next' because `rmail-mime-show' may change the buffer.
(cond ((looking-at "--[ \t]*$")
- (setq next (point-max-marker)))
+ (setq next (point-max-marker)
+ last t))
((looking-at "[ \t]*\n")
(setq next (copy-marker (match-end 0) t)))
+ (truncated
+ ;; We're handling what's left of a truncated message.
+ (setq next (point-max-marker)))
(t
- (rmail-mm-get-boundary-error-message
- "Malformed boundary" content-type content-disposition
- content-transfer-encoding)))
-
- (setq index (1+ index))
- ;; Handle the part.
- (if parse-tag
+ ;; The original code signaled an error as below, but
+ ;; this line may be a boundary of nested multipart. So,
+ ;; we just set `next' to nil to skip this line
+ ;; (rmail-mm-get-boundary-error-message
+ ;; "Malformed boundary" content-type content-disposition
+ ;; content-transfer-encoding)
+ (setq next nil)))
+
+ (when next
+ (setq index (1+ index))
+ ;; Handle the part.
+ (if parse-tag
+ (save-restriction
+ (narrow-to-region beg end)
+ (let ((child (rmail-mime-process
+ nil (format "%s/%d" parse-tag index)
+ content-type content-disposition)))
+ ;; Display a tagline.
+ (aset (aref (rmail-mime-entity-display child) 1) 1
+ (aset (rmail-mime-entity-tagline child) 2 t))
+ (rmail-mime-entity-set-truncated child truncated)
+ (push child entities)))
+
+ (delete-region end next)
(save-restriction
(narrow-to-region beg end)
- (let ((child (rmail-mime-process
- nil (format "%s/%d" parse-tag index)
- content-type content-disposition)))
- ;; Display a tagline.
- (aset (aref (rmail-mime-entity-display child) 1) 1
- (aset (rmail-mime-entity-tagline child) 2 t))
- (push child entities)))
-
- (delete-region end next)
- (save-restriction
- (narrow-to-region beg end)
- (rmail-mime-show)))
- (goto-char (setq beg next)))
+ (rmail-mime-show)))
+ (goto-char (setq beg next))))
(when parse-tag
(setq entities (nreverse entities))
(if (string-match "alternative" subtype)
;; Find the best entity to show, and hide all the others.
- (let (best second)
+ ;; If rmail-mime-prefer-html is set, html is best, then plain.
+ ;; If not, plain is best, then html.
+ ;; Then comes any other text part.
+ ;; If thereto of the same type, earlier entities in the message (later
+ ;; in the reverse list) are preferred.
+ (let (best best-priority)
(dolist (child entities)
(if (string= (or (car (rmail-mime-entity-disposition child))
(car content-disposition))
"inline")
- (if (string-match "text/plain"
- (car (rmail-mime-entity-type child)))
- (setq best child)
- (if (string-match "text/.*"
- (car (rmail-mime-entity-type child)))
- (setq second child)))))
- (or best (not second) (setq best second))
+ (let ((type (car (rmail-mime-entity-type child))))
+ (if (string-match "text/" type)
+ ;; Consider all inline text parts
+ (let ((priority
+ (cond ((string-match "text/html" type)
+ (if rmail-mime-prefer-html 1 2))
+ ((string-match "text/plain" type)
+ (if rmail-mime-prefer-html 2 1))
+ (t 3))))
+ (if (or (null best) (<= priority best-priority))
+ (setq best child
+ best-priority priority)))))))
(dolist (child entities)
(unless (eq best child)
(aset (rmail-mime-entity-body child) 2 nil)
(rmail-mime-hidden-mode child)))))
entities)))
-(defun test-rmail-mime-multipart-handler ()
- "Test of a mail used as an example in RFC 2046."
- (let ((mail "From: Nathaniel Borenstein <nsb@bellcore.com>
-To: Ned Freed <ned@innosoft.com>
-Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST)
-Subject: Sample message
-MIME-Version: 1.0
-Content-type: multipart/mixed; boundary=\"simple boundary\"
-
-This is the preamble. It is to be ignored, though it
-is a handy place for composition agents to include an
-explanatory note to non-MIME conformant readers.
-
---simple boundary
-
-This is implicitly typed plain US-ASCII text.
-It does NOT end with a linebreak.
---simple boundary
-Content-type: text/plain; charset=us-ascii
-
-This is explicitly typed plain US-ASCII text.
-It DOES end with a linebreak.
-
---simple boundary--
-
-This is the epilogue. It is also to be ignored."))
- (switch-to-buffer (get-buffer-create "*test*"))
- (erase-buffer)
- (insert mail)
- (rmail-mime-show t)))
-
(defun rmail-mime-insert-multipart (entity)
"Presentation handler for a multipart MIME entity."
(let ((current (aref (rmail-mime-entity-display entity) 0))
(beg (point))
(segment (rmail-mime-entity-segment (point) entity)))
;; header
- (if (eq (aref current 0) (aref new 0))
+ (if (eq (rmail-mime-display-header current)
+ (rmail-mime-display-header new))
(goto-char (aref segment 2))
- (if (aref current 0)
+ (if (rmail-mime-display-header current)
(delete-char (- (aref segment 2) (aref segment 1))))
- (if (aref new 0)
+ (if (rmail-mime-display-header new)
(rmail-mime-insert-header header)))
;; tagline
- (if (eq (aref current 1) (aref new 1))
- (if (or (not (aref current 1))
- (eq (aref current 2) (aref new 2)))
+ (if (eq (rmail-mime-display-tagline current)
+ (rmail-mime-display-tagline new))
+ (if (or (not (rmail-mime-display-tagline current))
+ (eq (rmail-mime-display-body current)
+ (rmail-mime-display-body new)))
(forward-char (- (aref segment 3) (aref segment 2)))
(rmail-mime-update-tagline entity))
- (if (aref current 1)
+ (if (rmail-mime-display-tagline current)
(delete-char (- (aref segment 3) (aref segment 2))))
- (if (aref new 1)
+ (if (rmail-mime-display-tagline new)
(rmail-mime-insert-tagline entity)))
(put-text-property beg (point) 'rmail-mime-entity entity)
;; body
- (if (eq (aref current 2) (aref new 2))
+ (if (eq (rmail-mime-display-body current)
+ (rmail-mime-display-body new))
(forward-char (- (aref segment 4) (aref segment 3)))
(dolist (child (rmail-mime-entity-children entity))
(rmail-mime-insert child)))
CONTENT-TYPE, CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING
are the values of the respective parsed headers. The latter should
-be downcased. The parsed headers for CONTENT-TYPE and CONTENT-DISPOSITION
+be lower-case. The parsed headers for CONTENT-TYPE and CONTENT-DISPOSITION
have the form
- \(VALUE . ALIST)
+ (VALUE . ALIST)
In other words:
- \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)
+ (VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)
VALUE is a string and ATTRIBUTE is a symbol.
The parsed header value:
\(\"multipart/mixed\"
- \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))"
+ (\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))"
;; Handle the content transfer encodings we know. Unknown transfer
;; encodings will be passed on to the various handlers.
(cond ((string= content-transfer-encoding "base64")
(if parse-tag
(let* ((is-inline (string= (car content-disposition) "inline"))
- (header (vector (point-min) end nil))
+ (hdr-end (copy-marker end))
+ (header (vector (point-min-marker) hdr-end nil))
(tagline (vector parse-tag (cons nil nil) t))
- (body (vector end (point-max) is-inline))
+ (body (vector hdr-end (point-max-marker) is-inline))
(new (vector (aref header 2) (aref tagline 2) (aref body 2)))
children handler entity)
(cond ((string-match "multipart/.*" (car content-type))
(save-restriction
(narrow-to-region (1- end) (point-max))
+ (if (zerop (length parse-tag)) ; top level of message
+ (aset new 1 (aset tagline 2 nil))) ; don't show tagline
(setq children (rmail-mime-process-multipart
content-type
content-disposition
(aset (rmail-mime-entity-tagline msg) 2 nil)
(setq children (list msg)
handler 'rmail-mime-insert-multipart))))
+ ((and is-inline (string-match "text/html" (car content-type)))
+ ;; Display tagline, so part can be detached
+ (aset new 1 (aset tagline 2 t))
+ (aset new 2 (aset body 2 t)) ; display body also.
+ (setq handler 'rmail-mime-insert-bulk))
+ ;; Inline non-HTML text
((and is-inline (string-match "text/" (car content-type)))
;; Don't need a tagline.
(aset new 1 (aset tagline 2 nil))
;; Hide headers and handle the part.
(put-text-property (point-min) (point-max) 'rmail-mime-entity
(rmail-mime-entity
- content-type content-disposition
- content-transfer-encoding
- (vector (vector 'raw nil 'raw) (vector 'raw nil 'raw))
- (vector nil nil 'raw) (vector "" (cons nil nil) nil)
- (vector nil nil 'raw) nil nil))
+ content-type content-disposition
+ content-transfer-encoding
+ (vector (vector 'raw nil 'raw) (vector 'raw nil 'raw))
+ (vector nil nil 'raw) (vector "" (cons nil nil) nil)
+ (vector nil nil 'raw) nil nil))
(save-restriction
(cond ((string= (car content-type) "message/rfc822")
(narrow-to-region end (point-max)))
(defun rmail-mime-parse ()
"Parse the current Rmail message as a MIME message.
-The value is a MIME-entiy object (see `rmail-mime-entity').
+The value is a MIME-entity object (see `rmail-mime-entity').
If an error occurs, return an error message string."
(let ((rmail-mime-mbox-buffer (if (rmail-buffers-swapped-p)
rmail-view-buffer
(new (aref (rmail-mime-entity-display entity) 1)))
;; Show header.
(aset new 0 (aset (rmail-mime-entity-header entity) 2 t))
- ;; Show tagline if and only if body is not shown.
- (if (aref new 2)
- (aset new 1 (aset (rmail-mime-entity-tagline entity) 2 nil))
- (aset new 1 (aset (rmail-mime-entity-tagline entity) 2 t)))
entity)))
(error (format "%s" err)))))
available."
(let ((current (aref (rmail-mime-entity-display entity) 0))
(new (aref (rmail-mime-entity-display entity) 1)))
- (if (not (eq (aref new 0) 'raw))
+ (if (not (eq (rmail-mime-display-header new) 'raw))
;; Not a raw-mode. Each handler should handle it.
(funcall (rmail-mime-entity-handler entity) entity)
(let ((header (rmail-mime-entity-header entity))
(beg (point))
(segment (rmail-mime-entity-segment (point) entity)))
;; header
- (if (eq (aref current 0) (aref new 0))
+ (if (eq (rmail-mime-display-header current)
+ (rmail-mime-display-header new))
(goto-char (aref segment 2))
- (if (aref current 0)
+ (if (rmail-mime-display-header current)
(delete-char (- (aref segment 2) (aref segment 1))))
(insert-buffer-substring rmail-mime-mbox-buffer
- (aref header 0) (aref header 1)))
+ (aref header 0) (aref header 1)))
;; tagline
- (if (aref current 1)
+ (if (rmail-mime-display-tagline current)
(delete-char (- (aref segment 3) (aref segment 2))))
;; body
(let ((children (rmail-mime-entity-children entity)))
(put-text-property beg (point) 'rmail-mime-entity entity)
(dolist (child children)
(rmail-mime-insert child)))
- (if (eq (aref current 2) (aref new 2))
+ (if (eq (rmail-mime-display-body current)
+ (rmail-mime-display-body new))
(forward-char (- (aref segment 4) (aref segment 3)))
- (if (aref current 2)
+ (if (rmail-mime-display-body current)
(delete-char (- (aref segment 4) (aref segment 3))))
(insert-buffer-substring rmail-mime-mbox-buffer
(aref body 0) (aref body 1))
(setq font-lock-defaults '(rmail-font-lock-keywords t t nil nil)))
;;;###autoload
-(defun rmail-mime (&optional arg)
- "Toggle displaying of a MIME message.
-
-The actualy behavior depends on the value of `rmail-enable-mime'.
-
-If `rmail-enable-mime' is t (default), this command change the
-displaying of a MIME message between decoded presentation form
-and raw data.
-
-With ARG, toggle the displaying of the current MIME entity only.
-
-If `rmail-enable-mime' is nil, this creates a temporary
-\"*RMAIL*\" buffer holding a decoded copy of the message. Inline
-content-types are handled according to
-`rmail-mime-media-type-handlers-alist'. By default, this
-displays text and multipart messages, and offers to download
-attachments as specfied by `rmail-mime-attachment-dirs-alist'."
- (interactive "P")
+(defun rmail-mime (&optional arg state)
+ "Toggle the display of a MIME message.
+
+The actual behavior depends on the value of `rmail-enable-mime'.
+
+If `rmail-enable-mime' is non-nil (the default), this command toggles
+the display of a MIME message between decoded presentation form and
+raw data. With optional prefix argument ARG, it toggles the display only
+of the MIME entity at point, if there is one. The optional argument
+STATE forces a particular display state, rather than toggling.
+`raw' forces raw mode, any other non-nil value forces decoded mode.
+
+If `rmail-enable-mime' is nil, this creates a temporary \"*RMAIL*\"
+buffer holding a decoded copy of the message. Inline content-types are
+handled according to `rmail-mime-media-type-handlers-alist'.
+By default, this displays text and multipart messages, and offers to
+download attachments as specified by `rmail-mime-attachment-dirs-alist'.
+The arguments ARG and STATE have no effect in this case."
+ (interactive (list current-prefix-arg nil))
(if rmail-enable-mime
(with-current-buffer rmail-buffer
- (if (rmail-mime-message-p)
- (let ((rmail-mime-mbox-buffer rmail-view-buffer)
- (rmail-mime-view-buffer rmail-buffer)
- (entity (get-text-property (point) 'rmail-mime-entity)))
- (if arg
- (if entity
- (rmail-mime-toggle-raw entity))
- (goto-char (point-min))
- (rmail-mime-toggle-raw
- (get-text-property (point) 'rmail-mime-entity))))
- (message "Not a MIME message")))
+ (if (or (rmail-mime-message-p)
+ (get-text-property (point-min) 'rmail-mime-hidden))
+ (let* ((hidden (get-text-property (point-min) 'rmail-mime-hidden))
+ (desired-hidden (if state (eq state 'raw) (not hidden))))
+ (unless (eq hidden desired-hidden)
+ (if (not desired-hidden)
+ (rmail-show-message rmail-current-message)
+ (let ((rmail-enable-mime nil)
+ (inhibit-read-only t))
+ (rmail-show-message rmail-current-message)
+ (add-text-properties (point-min) (point-max) '(rmail-mime-hidden t))))))
+ (message "Not a MIME message, just toggling headers")
+ (rmail-toggle-header)))
(let* ((data (rmail-apply-in-message rmail-current-message 'buffer-string))
(buf (get-buffer-create "*RMAIL*"))
(rmail-mime-mbox-buffer rmail-view-buffer)
(view-buffer buf))))
(defun rmail-mm-get-boundary-error-message (message type disposition encoding)
- "Return MESSAGE with more information on the main mime components."
+ "Return MESSAGE with more information on the main MIME components."
(error "%s; type: %s; disposition: %s; encoding: %s"
message type disposition encoding))
(defun rmail-show-mime ()
- "Function to set in `rmail-show-mime-function' (which see)."
+ "Function to use for the value of `rmail-show-mime-function'."
(let ((entity (rmail-mime-parse))
(rmail-mime-mbox-buffer rmail-buffer)
(rmail-mime-view-buffer rmail-view-buffer)
(rmail-mime-coding-system nil))
+ ;; If ENTITY is not a vector, it is a string describing an error.
(if (vectorp entity)
(with-current-buffer rmail-mime-view-buffer
(erase-buffer)
- (rmail-mime-insert entity)
- (if (consp rmail-mime-coding-system)
- ;; Decoding is done by rfc2047-decode-region only for a
- ;; header. But, as the used coding system may have been
- ;; overriden by mm-charset-override-alist, we can't
- ;; trust (car rmail-mime-coding-system). So, here we
- ;; try the decoding again with mm-charset-override-alist
- ;; bound to nil.
- (let ((mm-charset-override-alist nil))
- (setq rmail-mime-coding-system
- (rmail-mime-find-header-encoding
- (rmail-mime-entity-header entity)))))
- (set-buffer-file-coding-system
- (if rmail-mime-coding-system
- (coding-system-base rmail-mime-coding-system)
- 'undecided)
- t t))
+ ;; This condition-case is for catching an error in the
+ ;; internal MIME decoding (e.g. incorrect BASE64 form) that
+ ;; may be signaled by rmail-mime-insert.
+ ;; FIXME: The current code doesn't set a proper error symbol
+ ;; in ERR. We must find a way to propagate a correct error
+ ;; symbol that is caused in the very deep code of text
+ ;; decoding (e.g. an error by base64-decode-region called by
+ ;; post-read-conversion function of utf-7).
+ (condition-case err
+ (progn
+ (rmail-mime-insert entity)
+ (if (consp rmail-mime-coding-system)
+ ;; Decoding is done by rfc2047-decode-region only for a
+ ;; header. But, as the used coding system may have been
+ ;; overridden by mm-charset-override-alist, we can't
+ ;; trust (car rmail-mime-coding-system). So, here we
+ ;; try the decoding again with mm-charset-override-alist
+ ;; bound to nil.
+ (let ((mm-charset-override-alist nil))
+ (setq rmail-mime-coding-system
+ (rmail-mime-find-header-encoding
+ (rmail-mime-entity-header entity)))))
+ (set-buffer-file-coding-system
+ (if rmail-mime-coding-system
+ (coding-system-base rmail-mime-coding-system)
+ 'undecided)
+ t t))
+ (error (setq entity (format "%s" err))))))
+ ;; Re-check ENTITY. It may be set to an error string.
+ (when (stringp entity)
;; Decoding failed. ENTITY is an error message. Insert the
;; original message body as is, and show warning.
(let ((region (with-current-buffer rmail-mime-mbox-buffer
(setq rmail-show-mime-function 'rmail-show-mime)
(defun rmail-insert-mime-forwarded-message (forward-buffer)
- "Function to set in `rmail-insert-mime-forwarded-message-function' (which see)."
- (let ((rmail-mime-mbox-buffer
- (with-current-buffer forward-buffer rmail-view-buffer)))
- (save-restriction
- (narrow-to-region (point) (point))
- (message-forward-make-body-mime rmail-mime-mbox-buffer))))
+ "Insert the message in FORWARD-BUFFER as a forwarded message.
+This is the usual value of `rmail-insert-mime-forwarded-message-function'."
+ (let (contents-buffer start end)
+ (with-current-buffer forward-buffer
+ (setq contents-buffer
+ (if rmail-buffer-swapped
+ rmail-view-buffer
+ forward-buffer)
+ start (rmail-msgbeg rmail-current-message)
+ end (rmail-msgend rmail-current-message)))
+ (message-forward-make-body-mime contents-buffer start end)))
(setq rmail-insert-mime-forwarded-message-function
'rmail-insert-mime-forwarded-message)
"Function to set in `rmail-search-mime-message-function' (which see)."
(save-restriction
(narrow-to-region (rmail-msgbeg msg) (rmail-msgend msg))
- (let* ((rmail-mime-mbox-buffer (current-buffer))
+ (let* ((rmail-mime-searching t) ; mark inside search
+ (rmail-mime-mbox-buffer (current-buffer))
(rmail-mime-view-buffer rmail-view-buffer)
(header-end (save-excursion
(re-search-forward "^$" nil 'move) (point)))
(re-search-forward regexp nil t))
;; Next, search the body.
(if (and entity
+ ;; RMS: I am not sure why, but sometimes this is a string.
+ (not (stringp entity))
(let* ((content-type (rmail-mime-entity-type entity))
(charset (cdr (assq 'charset (cdr content-type)))))
(or (not (string-match "text/.*" (car content-type)))
(provide 'rmailmm)
;; Local Variables:
-;; generated-autoload-file: "rmail.el"
+;; generated-autoload-file: "rmail-loaddefs.el"
;; End:
;;; rmailmm.el ends here