;;; rmailmm.el --- MIME decoding and display stuff for RMAIL
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
;; Author: Alexander Pohoyda
;; Alex Schroeder
;; Maintainer: FSF
;; Keywords: mail
+;; Package: rmail
;; This file is part of GNU Emacs.
;;
;; rmail-mime
;; +- rmail-mime-show <----------------------------------+
-;; +- rmail-mime-process |
+;; +- rmail-mime-process |
;; +- rmail-mime-handle |
;; +- rmail-mime-text-handler |
;; +- rmail-mime-bulk-handler |
;;; MIME-entity object
(defun rmail-mime-entity (type disposition transfer-encoding
- display header tagline body children handler)
+ display header tagline body children handler
+ &optional truncated)
"Retrun 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 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:
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.
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-entity-truncated (entity) (aref entity 9))
+(defsubst rmail-mime-entity-set-truncated (entity truncated)
+ (aset entity 9 truncated))
(defsubst rmail-mime-message-p ()
"Non-nil if and only if the current message is a MIME."
(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
(aset new 2 (aref (rmail-mime-entity-body entity) 2)))
(dolist (child (rmail-mime-entity-children entity))
(rmail-mime-shown-mode child)))
-
+
(defun rmail-mime-hidden-mode (entity)
"Make MIME-entity ENTITY displayed in the hidden mode."
(let ((new (aref (rmail-mime-entity-display entity) 1)))
(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.
"Insert a tag line for MIME-entity ENTITY.
ITEM-LIST is a list of strings or button-elements (list) to be added
to the tag line."
- (insert "[")
+ (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)) " ")
(if (stringp item)
(insert item)
(apply 'insert-button item))))
- (insert "]\n"))
-
+ (insert "]\n\n"))
+
(defun rmail-mime-update-tagline (entity)
"Update the current tag line for MIME-entity ENTITY."
(let ((inhibit-read-only t)
HEADER is a header component of a MIME-entity object (see
`rmail-mime-entity')."
(with-temp-buffer
- (let ((last-coding-system-used nil))
+ (let ((buf (current-buffer)))
(with-current-buffer rmail-mime-mbox-buffer
- (let ((rmail-buffer rmail-mime-mbox-buffer)
- (rmail-view-buffer rmail-mime-view-buffer))
+ (let ((last-coding-system-used nil)
+ (rmail-buffer rmail-mime-mbox-buffer)
+ (rmail-view-buffer buf))
(save-excursion
(goto-char (aref header 0))
(rmail-copy-headers (point) (aref header 1)))))
((string= transfer-encoding "quoted-printable")
(quoted-printable-decode-region pos (point))))))
(decode-coding-region pos (point) coding-system)
- (if (or (not rmail-mime-coding-system) (consp rmail-mime-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))
(or (bolp) (insert "\n"))))
(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))))
(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))
(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)
(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.
+ (and (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.
(setq next (point-max-marker)))
((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 signalled 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 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))
;; 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))
+ (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))
(save-restriction
(cond ((string= (car content-type) "message/rfc822")
(narrow-to-region end (point-max)))
(rmail-mime-find-header-encoding
(rmail-mime-entity-header entity)))))
(set-buffer-file-coding-system
- (coding-system-base rmail-mime-coding-system) t t))
+ (if rmail-mime-coding-system
+ (coding-system-base rmail-mime-coding-system)
+ 'undecided)
+ t t))
;; 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)))
+ "Insert the message in FORWARD-BUFFER as a forwarded message.
+This is the usual value of `rmail-insert-mime-forwarded-message-function'."
+ (let ((message-buffer
+ (with-current-buffer forward-buffer
+ (if rmail-buffer-swapped
+ forward-buffer
+ rmail-view-buffer))))
(save-restriction
(narrow-to-region (point) (point))
- (message-forward-make-body-mime rmail-mime-mbox-buffer))))
+ (message-forward-make-body-mime message-buffer))))
(setq rmail-insert-mime-forwarded-message-function
'rmail-insert-mime-forwarded-message)
(re-search-forward "^$" nil 'move) (point)))
(body-end (point-max))
(entity (rmail-mime-parse)))
- (or
+ (or
;; At first, just search the headers.
(with-temp-buffer
(insert-buffer-substring rmail-mime-mbox-buffer nil header-end)
(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)))
+ (or (not (string-match "text/.*" (car content-type)))
(and charset
(not (string= (downcase charset) "us-ascii"))))))
;; Search the decoded MIME message.
;; generated-autoload-file: "rmail.el"
;; End:
-;; arch-tag: 3f2c5e5d-1aef-4512-bc20-fd737c9d5dd9
;;; rmailmm.el ends here