;;; rmailmm.el --- MIME decoding and display stuff for RMAIL
-;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
;; Author: Alexander Pohoyda
;; Alex Schroeder
"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).
HEADER: the position of the beginning of a header
TAGLINE: the position of the beginning of a tagline
BODY: the position of the beginning of a body
- END: the position of the end of the entity.
- INDEX: index into the returned vector indicating where POS is."
+ END: the position of the end of the entity."
(save-excursion
(or entity
(setq entity (get-text-property pos 'rmail-mime-entity)))
(setq end body-beg))
(vector index beg tagline-beg body-beg end)))))
-(defun rmail-mime-next-item ()
- "Move point to the next displayed item of the current MIME entity.
-A MIME entity has three items; header, tagline, and body.
-If we are in the last item of the entity, move point to the first
-item of the next entity. If we reach the end of buffer, move
-point to the first item of the first entity (i.e. the beginning
-of buffer)."
- (interactive)
- (if (rmail-mime-message-p)
- (let* ((segment (rmail-mime-entity-segment (point)))
- (next-pos (aref segment (1+ (aref segment 0))))
- (button (next-button (point))))
- (goto-char (if (and button (< (button-start button) next-pos))
- (button-start button)
- next-pos))
- (if (eobp)
- (goto-char (point-min))))))
-
-(defun rmail-mime-previous-item ()
- "Move point to the previous displayed item of the current MIME message.
-A MIME entity has three items; header, tagline, and body.
-If we are at the beginning of the first item of the entity, move
-point to the last item of the previous entity. If we reach the
-beginning of buffer, move point to the last item of the last
-entity."
- (interactive)
- (when (rmail-mime-message-p)
- (if (bobp)
- (goto-char (point-max)))
- (let* ((segment (rmail-mime-entity-segment (1- (point))))
- (prev-pos (aref segment (aref segment 0)))
- (button (previous-button (point))))
- (goto-char (if (and button (> (button-start button) prev-pos))
- (button-start button)
- prev-pos)))))
-
(defun rmail-mime-shown-mode (entity)
"Make MIME-entity ENTITY displayed by 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))
- (aset new 2 (aref (rmail-mime-entity-body entity) 2))))
+ (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 top)
- "Make MIME-entity ENTITY displayed in the hidden mode.
-If TOP is non-nil, display ENTITY only by the tagline.
-Otherwise, don't display ENTITY."
- (if top
- (let ((new (aref (rmail-mime-entity-display entity) 1)))
- (aset new 0 nil)
- (aset new 1 top)
- (aset new 2 nil)
- (aset (rmail-mime-entity-body entity) 2 nil))
- (let ((current (aref (rmail-mime-entity-display entity) 0)))
- (aset current 0 nil)
- (aset current 1 nil)
- (aset current 2 nil)))
+(defun rmail-mime-hidden-mode (entity)
+ "Make MIME-entity ENTITY displayed in the hidden mode."
+ (let ((new (aref (rmail-mime-entity-display entity) 1)))
+ (aset new 0 nil)
+ (aset new 1 t)
+ (aset new 2 nil))
(dolist (child (rmail-mime-entity-children entity))
- (rmail-mime-hidden-mode child nil)))
+ (rmail-mime-hidden-mode child)))
(defun rmail-mime-raw-mode (entity)
"Make MIME-entity ENTITY displayed in the raw mode."
(let ((new (aref (rmail-mime-entity-display entity) 1)))
(aset new 0 'raw)
(aset new 1 nil)
- (aset new 2 'raw)
- (dolist (child (rmail-mime-entity-children entity))
- (rmail-mime-hidden-mode child nil))))
+ (aset new 2 'raw))
+ (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."
(restore-buffer-modified-p modified)))))
(defun rmail-mime-toggle-hidden ()
- "Toggle on and off the hidden display mode of MIME-entity ENTITY."
+ "Hide or show the body of MIME-entity at point."
(interactive)
(when (rmail-mime-message-p)
(let* ((rmail-mime-mbox-buffer rmail-view-buffer)
;; Enter the hidden mode.
(progn
;; If point is in the body part, move it to the tagline
- ;; (or the header if headline is not displayed).
+ ;; (or the header if tagline is not displayed).
(if (= (aref segment 0) 3)
(goto-char (aref segment 2)))
- (rmail-mime-hidden-mode entity t)
+ (rmail-mime-hidden-mode entity)
;; If the current entity is the topmost one, display the
;; header.
(if (and rmail-mime-mbox-buffer (= (aref segment 1) (point-min)))
(let ((new (aref (rmail-mime-entity-display entity) 1)))
(aset new 0 t))))
;; Enter the shown mode.
- (aset (rmail-mime-entity-body entity) 2 t)
- (rmail-mime-shown-mode entity))
+ (rmail-mime-shown-mode entity)
+ ;; Force this body shown.
+ (aset (aref (rmail-mime-entity-display entity) 1) 2 t))
(let ((inhibit-read-only t)
(modified (buffer-modified-p))
(rmail-mime-mbox-buffer rmail-view-buffer)
(rmail-mime-insert entity)
(restore-buffer-modified-p modified))))))
-(define-key rmail-mode-map "\t" 'rmail-mime-next-item)
-(define-key rmail-mode-map [backtab] 'rmail-mime-previous-item)
+(define-key rmail-mode-map "\t" 'forward-button)
+(define-key rmail-mode-map [backtab] 'backward-button)
(define-key rmail-mode-map "\r" 'rmail-mime-toggle-hidden)
;;; Handlers
(insert "[")
(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 (car (rmail-mime-entity-type entity)) " ")
+ (insert-button (let ((new (aref (rmail-mime-entity-display entity) 1)))
+ (if (aref new 2) "Hide" "Show"))
+ :type 'rmail-mime-toggle
+ 'help-echo "mouse-2, RET: Toggle show/hide")
(dolist (item item-list)
(when item
(if (stringp item)
(apply 'insert-button item))))
(insert "]\n"))
+(defun rmail-mime-update-tagline (entity)
+ "Update the current tag line for MIME-entity ENTITY."
+ (let ((inhibit-read-only t)
+ (modified (buffer-modified-p))
+ ;; If we are going to show the body, the new button label is
+ ;; "Hide". Otherwise, it's "Show".
+ (label (if (aref (aref (rmail-mime-entity-display entity) 1) 2) "Hide"
+ "Show"))
+ (button (next-button (point))))
+ ;; Go to the second character of the button "Show" or "Hide".
+ (goto-char (1+ (button-start button)))
+ (setq button (button-at (point)))
+ (save-excursion
+ (insert label)
+ (delete-region (point) (button-end button)))
+ (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)))
+
(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].
(rmail-copy-headers (point) (aref header 1)))))
(rfc2047-decode-region pos (point))
(if (and last-coding-system-used (not rmail-mime-coding-system))
- (setq rmail-mime-coding-system last-coding-system-used))
+ (setq rmail-mime-coding-system (cons last-coding-system-used nil)))
(goto-char (point-min))
(rmail-highlight-headers)
(goto-char (point-max))
(insert "\n"))))
+(defun rmail-mime-find-header-encoding (header)
+ "Retun 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
+ (let ((last-coding-system-used nil))
+ (with-current-buffer rmail-mime-mbox-buffer
+ (let ((rmail-buffer rmail-mime-mbox-buffer)
+ (rmail-view-buffer rmail-mime-view-buffer))
+ (save-excursion
+ (goto-char (aref header 0))
+ (rmail-copy-headers (point) (aref header 1)))))
+ (rfc2047-decode-region (point-min) (point-max))
+ last-coding-system-used)))
+
(defun rmail-mime-text-handler (content-type
content-disposition
content-transfer-encoding)
((string= transfer-encoding "quoted-printable")
(quoted-printable-decode-region pos (point))))))
(decode-coding-region pos (point) coding-system)
- (or rmail-mime-coding-system
+ (if (or (not rmail-mime-coding-system) (consp rmail-mime-coding-system))
(setq rmail-mime-coding-system coding-system))
(or (bolp) (insert "\n"))))
(rmail-mime-insert-header header)))
;; tagline
(if (eq (aref current 1) (aref new 1))
- (forward-char (- (aref segment 3) (aref segment 2)))
+ (if (or (not (aref current 1))
+ (eq (aref current 2) (aref new 2)))
+ (forward-char (- (aref segment 3) (aref segment 2)))
+ (rmail-mime-update-tagline entity))
(if (aref current 1)
(delete-char (- (aref segment 3) (aref segment 2))))
(if (aref new 1)
(insert-image (create-image data (cdr bulk-data) t))
(insert "\n")))
-(defun rmail-mime-image (button)
- "Display the image associated with BUTTON."
+(defun rmail-mime-toggle-button (button)
+ "Hide or show the body of the MIME-entity associated with BUTTON."
(save-excursion
- (goto-char (button-end button))
+ (goto-char (button-start button))
(rmail-mime-toggle-hidden)))
-(define-button-type 'rmail-mime-image 'action 'rmail-mime-image)
+(define-button-type 'rmail-mime-toggle 'action 'rmail-mime-toggle-button)
(defun rmail-mime-bulk-handler (content-type
(size (cdr (assq 'size (cdr (rmail-mime-entity-disposition entity)))))
(bulk-data (aref (rmail-mime-entity-tagline entity) 1))
(body (rmail-mime-entity-body entity))
- size type to-show)
+ type to-show)
(cond (size
(setq size (string-to-number size)))
((stringp (aref body 0))
(defun rmail-mime-insert-bulk (entity)
"Presentation handler for an attachment MIME entity."
- ;; Find the default directory for this media type.
(let* ((content-type (rmail-mime-entity-type entity))
(content-disposition (rmail-mime-entity-disposition entity))
(current (aref (rmail-mime-entity-display entity) 0))
(tagline (rmail-mime-entity-tagline entity))
(bulk-data (aref tagline 1))
(body (rmail-mime-entity-body entity))
+ ;; Find the default directory for this media type.
(directory (catch 'directory
(dolist (entry rmail-mime-attachment-dirs-alist)
(when (string-match (car entry) (car content-type))
;; tagline
(if (eq (aref current 1) (aref new 1))
- (forward-char (- (aref segment 3) (aref segment 2)))
+ (if (or (not (aref current 1))
+ (eq (aref current 2) (aref new 2)))
+ (forward-char (- (aref segment 3) (aref segment 2)))
+ (rmail-mime-update-tagline entity))
(if (aref current 1)
(delete-char (- (aref segment 3) (aref segment 2))))
(if (aref new 1)
(rmail-mime-insert-tagline
entity
- " file:"
+ " Save:"
(list filename
:type 'rmail-mime-save
'help-echo "mouse-2, RET: Save attachment"
'directory (file-name-as-directory directory)
'data data)
(format " (%.0f%s)" size (car units))
- (if (cdr bulk-data)
- " ")
- (if (cdr bulk-data)
- (list "Toggle show/hide"
- :type 'rmail-mime-image
- 'help-echo "mouse-2, RET: Toggle show/hide"
- 'image-type (cdr bulk-data)
- 'image-data data)))))
+ ;; We don't need this button because the "type" string of a
+ ;; tagline is the button to do this.
+ ;; (if (cdr bulk-data)
+ ;; " ")
+ ;; (if (cdr bulk-data)
+ ;; (list "Toggle show/hide"
+ ;; :type 'rmail-mime-image
+ ;; 'help-echo "mouse-2, RET: Toggle show/hide"
+ ;; 'image-type (cdr bulk-data)
+ ;; 'image-data data))
+ )))
;; body
(if (eq (aref current 2) (aref new 2))
(forward-char (- (aref segment 4) (aref segment 3)))
(cond ((eq (cdr bulk-data) 'text)
(rmail-mime-insert-decoded-text entity))
((cdr bulk-data)
- (rmail-mime-insert-image entity)))))
+ (rmail-mime-insert-image entity))
+ (t
+ ;; As we don't know how to display the body, just
+ ;; insert it as a text.
+ (rmail-mime-insert-decoded-text entity)))))
(put-text-property beg (point) 'rmail-mime-entity entity)))
(defun test-rmail-mime-bulk-handler ()
(cond ((string-match "mixed" subtype)
(setq content-type '("text/plain")))
((string-match "digest" subtype)
- (setq content-type '("message/rfc822"))))
+ (setq content-type '("message/rfc822")))
+ (t
+ (setq content-type nil)))
;; 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
(setq second child)))))
(or best (not second) (setq best second))
(dolist (child entities)
- (or (eq best child)
- (rmail-mime-hidden-mode child t)))))
+ (unless (eq best child)
+ (aset (rmail-mime-entity-body child) 2 nil)
+ (rmail-mime-hidden-mode child)))))
entities)))
(defun test-rmail-mime-multipart-handler ()
(rmail-mime-insert-header header)))
;; tagline
(if (eq (aref current 1) (aref new 1))
- (forward-char (- (aref segment 3) (aref segment 2)))
+ (if (or (not (aref current 1))
+ (eq (aref current 2) (aref new 2)))
+ (forward-char (- (aref segment 3) (aref segment 2)))
+ (rmail-mime-update-tagline entity))
(if (aref current 1)
(delete-char (- (aref segment 3) (aref segment 2))))
(if (aref new 1)
(rmail-mime-insert-tagline entity)))
(put-text-property beg (point) 'rmail-mime-entity entity)
+
;; body
(if (eq (aref current 2) (aref new 2))
(forward-char (- (aref segment 4) (aref segment 3)))
- (if (aref current 2)
- (delete-char (- (aref segment 4) (aref segment 3))))
- (if (aref new 2)
- (dolist (child (rmail-mime-entity-children entity))
- (rmail-mime-insert child))))))
+ (dolist (child (rmail-mime-entity-children entity))
+ (rmail-mime-insert child)))
+ entity))
;;; Main code
;; Everything else is an attachment.
(rmail-mime-bulk-handler content-type
content-disposition
- content-transfer-encoding)))
+ content-transfer-encoding))
+ (save-restriction
+ (widen)
+ (let ((entity (get-text-property (1- (point)) 'rmail-mime-entity))
+ current new)
+ (when entity
+ (setq current (aref (rmail-mime-entity-display entity) 0)
+ new (aref (rmail-mime-entity-display entity) 1))
+ (dotimes (i 3)
+ (aset current i (aref new i)))))))
(defun rmail-mime-show (&optional show-headers)
"Handle the current buffer as a MIME message.
(setq content-transfer-encoding (downcase content-transfer-encoding)))
(setq content-type
(if content-type
- (mail-header-parse-content-type content-type)
+ (or (mail-header-parse-content-type content-type)
+ '("text/plain"))
(or default-content-type '("text/plain"))))
(setq content-disposition
(if content-disposition
(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-entiy 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
(current-buffer))))
- ;;(condition-case err
+ (condition-case err
(with-current-buffer rmail-mime-mbox-buffer
(save-excursion
(goto-char (point-min))
(aset new 1 (aset (rmail-mime-entity-tagline entity) 2 nil))
(aset new 1 (aset (rmail-mime-entity-tagline entity) 2 t)))
entity)))
- ;;(error (error (format "%s" err))))
- ))
+ (error (format "%s" err)))))
(defun rmail-mime-insert (entity)
"Insert a MIME-entity ENTITY in the current buffer.
(if (aref current 1)
(delete-char (- (aref segment 3) (aref segment 2))))
;; body
- (if (eq (aref current 2) (aref new 2))
- (forward-char (- (aref segment 4) (aref segment 3)))
- (if (aref current 2)
- (delete-char (- (aref segment 4) (aref segment 3))))
- (insert-buffer-substring rmail-mime-mbox-buffer
- (aref body 0) (aref body 1)))
- (put-text-property beg (point) 'rmail-mime-entity entity)))
+ (let ((children (rmail-mime-entity-children entity)))
+ (if children
+ (progn
+ (put-text-property beg (point) 'rmail-mime-entity entity)
+ (dolist (child children)
+ (rmail-mime-insert child)))
+ (if (eq (aref current 2) (aref new 2))
+ (forward-char (- (aref segment 4) (aref segment 3)))
+ (if (aref current 2)
+ (delete-char (- (aref segment 4) (aref segment 3))))
+ (insert-buffer-substring rmail-mime-mbox-buffer
+ (aref body 0) (aref body 1))
+ (or (bolp) (insert "\n")))
+ (put-text-property beg (point) 'rmail-mime-entity entity)))))
(dotimes (i 3)
(aset current i (aref new i)))))
attachments as specfied by `rmail-mime-attachment-dirs-alist'."
(interactive "P")
(if rmail-enable-mime
- (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"))
+ (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")))
(let* ((data (rmail-apply-in-message rmail-current-message 'buffer-string))
(buf (get-buffer-create "*RMAIL*"))
(rmail-mime-mbox-buffer rmail-view-buffer)
(rmail-mime-mbox-buffer rmail-buffer)
(rmail-mime-view-buffer rmail-view-buffer)
(rmail-mime-coding-system nil))
- (if entity
+ (if (vectorp entity)
(with-current-buffer rmail-mime-view-buffer
(erase-buffer)
(rmail-mime-insert entity)
- (if rmail-mime-coding-system
- (set-buffer-file-coding-system rmail-mime-coding-system t t)))
- ;; Decoding failed. Insert the original message body as is.
+ (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
+ (coding-system-base rmail-mime-coding-system) 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
(goto-char (point-min))
(re-search-forward "^$" nil t)
(forward-line 1)
- (cons (point) (point-max)))))
+ (vector (point-min) (point) (point-max)))))
(with-current-buffer rmail-mime-view-buffer
(let ((inhibit-read-only t))
(erase-buffer)
+ (rmail-mime-insert-header region)
(insert-buffer-substring rmail-mime-mbox-buffer
- (car region) (cdr region))))
+ (aref region 1) (aref region 2))))
(set-buffer-file-coding-system 'no-conversion t t)
- (message "MIME decoding failed")))))
+ (message "MIME decoding failed: %s" entity)))))
(setq rmail-show-mime-function 'rmail-show-mime)