From 186f7f0b7f48751df956707de5476e63ca4c1dbe Mon Sep 17 00:00:00 2001 From: Kenichi Handa Date: Fri, 24 Dec 2010 13:38:22 +0900 Subject: [PATCH] Enable display mode of MIME message in rmail. --- etc/NEWS | 21 + lisp/ChangeLog | 43 ++ lisp/mail/rmail.el | 137 +++--- lisp/mail/rmailmm.el | 980 ++++++++++++++++++++++++++++++++----------- 4 files changed, 879 insertions(+), 302 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index ebc1f0afc9e..1bf17eff7a1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -72,6 +72,27 @@ Bazaar recognizes the headers "Author", "Date" and "Fixes". Git, Mercurial, and Monotone recognize "Author" and "Date". Any unknown header is left as is in the message, so it is not lost. +** Rmail + +** The default value of `rmail-enable-mime' is now t. Rmail decodes +MIME contents automatically. You can customize the variable +`rmail-enable-mime' back to `nil' to disable this automatic MIME +decoding. + +** The command `rmail-mime' change the displaying of a MIME message +between decoded presentation form and raw data if `rmail-enable-mime' +is non-nil. And, with prefix argument, it change only the displaying +of the MIME entity at point. + +** The new command TAB (rmail-mime-next-item) moves point to the next +item of MIME message. + +** The new command backtab (rmail-mime-previous-item) moves point to +the previous item of MIME message. + +** The new command RET (rmail-mime-toggle-hidden) hide or show the +body of the MIME entity at point. + ** Obsolete packages +++ diff --git a/lisp/ChangeLog b/lisp/ChangeLog index dcdfa3ebc88..ee6848449c7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,46 @@ +2010-12-24 Kenichi Handa + + * mail/rmailmm.el: New key bindings for rmail-mime-next-item, + rmail-mime-previous-item, and rmail-mime-toggle-hidden. + (rmail-mime-mbox-buffer) + (rmail-mime-view-buffer, rmail-mime-coding-system): New variables. + (rmail-mime-entity): Argument changed. All codes handling an + entity object are changed. + (rmail-mime-entity-header, rmail-mime-entity-body): Adjusted for + the above change. + (rmail-mime-entity-children, rmail-mime-entity-handler) + (rmail-mime-entity-tagline): New functions. + (rmail-mime-message-p): New function. + (rmail-mime-save): Bind rmail-mime-mbox-buffer. + (rmail-mime-entity-segment, rmail-mime-next-item) + (rmail-mime-previous-item, rmail-mime-shown-mode) + (rmail-mime-hidden-mode, rmail-mime-raw-mode) + (rmail-mime-toggle-raw, rmail-mime-toggle-hidden) + (rmail-mime-insert-tagline, rmail-mime-insert-header): New + functions. + (rmail-mime-text-handler): Call rmail-mime-insert-text. + (rmail-mime-insert-decoded-text): New function. + (rmail-mime-insert-text): Call rmail-mime-insert-decoded-text. + (rmail-mime-insert-image): Argument changed. Caller changed. + (rmail-mime-image): Call rmail-mime-toggle-hidden. + (rmail-mime-set-bulk-data): New funciton. + (rmail-mime-insert-bulk): Argument changed. + (rmail-mime-multipart-handler): Return t. + (rmail-mime-process-multipart): Argument changed. Handle + "multipart/alternative" here. + (rmail-mime-process): Argument changed. + (rmail-mime-parse): Bind rmail-mime-mbox-buffer. + (rmail-mime-insert): Argument changed. Handle raw display mode. + (rmail-mime): Argument changed. Handle toggling of raw display + mode. + (rmail-show-mime): Bind rmail-mime-mbox-buffer and + rmail-mime-view-buffer. + (rmail-insert-mime-forwarded-message): Likewise. + (rmail-search-mime-message): Likewise. Don't bind rmail-buffer. + + * mail/rmail.el (rmail-show-message-1): If rmail-enable-mime is + non-nil, handle the header in rmail-show-mime-function. + 2010-12-20 Leo * help-fns.el (describe-variable): Fix 2010-12-17 change. diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 3f5660e82cb..af09e5468a4 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -2691,75 +2691,72 @@ The current mail message becomes the message displayed." (message "Showing message %d" msg)) (narrow-to-region beg end) (goto-char beg) - (if (and rmail-enable-mime - (re-search-forward "mime-version: 1.0" nil t)) - (let ((rmail-buffer mbox-buf) - (rmail-view-buffer view-buf)) - (funcall rmail-show-mime-function)) - (setq body-start (search-forward "\n\n" nil t)) - (narrow-to-region beg (point)) - (goto-char beg) - (save-excursion - (if (re-search-forward "^X-Coding-System: *\\(.*\\)$" nil t) - (setq coding-system (intern (match-string 1))) - (setq coding-system (rmail-get-coding-system)))) - (setq character-coding (mail-fetch-field "content-transfer-encoding") - is-text-message (rmail-is-text-p)) - (if character-coding - (setq character-coding (downcase character-coding))) - (narrow-to-region beg end) - ;; Decode the message body into an empty view buffer using a - ;; unibyte temporary buffer where the character decoding takes - ;; place. - (with-current-buffer rmail-view-buffer - (erase-buffer)) - (if (null character-coding) - ;; Do it directly since that is fast. - (rmail-decode-region body-start end coding-system view-buf) - ;; Can this be done directly, skipping the temp buffer? - (with-temp-buffer - (set-buffer-multibyte nil) - (insert-buffer-substring mbox-buf body-start end) - (cond - ((string= character-coding "quoted-printable") - ;; See bug#5441. - (or (mail-unquote-printable-region (point-min) (point-max) - nil t 'unibyte) - (message "Malformed MIME quoted-printable message"))) - ((and (string= character-coding "base64") is-text-message) - (condition-case err - (base64-decode-region (point-min) (point-max)) - (error (message "%s" (cdr err))))) - ((eq character-coding 'uuencode) - (error "uuencoded messages are not supported yet")) - (t)) - (rmail-decode-region (point-min) (point-max) - 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) - (beginning-of-line) - (delete-char 1) - (forward-line)) - (goto-char (point-min))) - ;; Copy the headers to the front of the message view buffer. - (rmail-copy-headers beg end) - ;; Add the separator (blank line) between headers and body; + (set (make-local-variable 'rmail-header-style) header-style)) + (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) + (save-excursion + (if (re-search-forward "^X-Coding-System: *\\(.*\\)$" nil t) + (setq coding-system (intern (match-string 1))) + (setq coding-system (rmail-get-coding-system)))) + (setq character-coding (mail-fetch-field "content-transfer-encoding") + is-text-message (rmail-is-text-p)) + (if character-coding + (setq character-coding (downcase character-coding))) + (narrow-to-region beg end) + ;; Decode the message body into an empty view buffer using a + ;; unibyte temporary buffer where the character decoding takes + ;; place. + (with-current-buffer rmail-view-buffer + (erase-buffer)) + (if (null character-coding) + ;; Do it directly since that is fast. + (rmail-decode-region body-start end coding-system view-buf) + ;; Can this be done directly, skipping the temp buffer? + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-buffer-substring mbox-buf body-start end) + (cond + ((string= character-coding "quoted-printable") + ;; See bug#5441. + (or (mail-unquote-printable-region (point-min) (point-max) + nil t 'unibyte) + (message "Malformed MIME quoted-printable message"))) + ((and (string= character-coding "base64") is-text-message) + (condition-case err + (base64-decode-region (point-min) (point-max)) + (error (message "%s" (cdr err))))) + ((eq character-coding 'uuencode) + (error "uuencoded messages are not supported yet")) + (t)) + (rmail-decode-region (point-min) (point-max) + coding-system view-buf))) + (with-current-buffer rmail-view-buffer + ;; Prepare the separator (blank line) before the body. + (goto-char (point-min)) + (insert "\n") + ;; Unquote quoted From lines + (while (re-search-forward "^>+From " nil t) + (beginning-of-line) + (delete-char 1) + (forward-line)) + (goto-char (point-min))) + ;; Copy the headers to the front of the message view buffer. + (rmail-copy-headers beg end)) ;; highlight the message, activate any URL like text and add ;; special highlighting for and quoted material. (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) @@ -4290,18 +4287,28 @@ With prefix argument N moves forward N messages with these labels. ;;;*** -;;;### (autoloads (rmail-mime) "rmailmm" "rmailmm.el" "222ca7c1e672a08e5799e5a72fb25049") +;;;### (autoloads (rmail-mime) "rmailmm" "rmailmm.el" "faa9e26c7781c426785e671a040128ad") ;;; Generated autoloads from rmailmm.el (autoload 'rmail-mime "rmailmm" "\ -Process the current Rmail message as a MIME message. -This creates a temporary \"*RMAIL*\" buffer holding a decoded -copy of the message. Inline content-types are handled according to +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'. -\(fn)" t nil) +\(fn &optional ARG)" t nil) ;;;*** diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el index 1cd765cbf9f..5733945d5f2 100644 --- a/lisp/mail/rmailmm.el +++ b/lisp/mail/rmailmm.el @@ -96,7 +96,9 @@ The first item is a regular expression matching a content-type. The remaining elements are handler functions to run, in order of decreasing preference. These are called until one returns non-nil. Note that this only applies to items with an inline Content-Disposition, -all others are handled by `rmail-mime-bulk-handler'." +all others are handled by `rmail-mime-bulk-handler'. +Note also that this alist is ignored when the variable +`rmail-enable-mime' is non-nil." :type '(alist :key-type regexp :value-type (repeat function)) :version "23.1" :group 'rmail-mime) @@ -130,18 +132,36 @@ automatically display the image in the buffer." ;;; End of user options. +;;; Global variables that always have let-binding when referred. + +(defvar rmail-mime-mbox-buffer nil + "Buffer containing the mbox data. +The value is usually nil, and bound to a proper value while +processing MIME.") + +(defvar rmail-mime-view-buffer nil + "Buffer showing a message. +The value is usually nil, and bound to a proper value while +processing MIME.") + +(defvar rmail-mime-coding-system nil + "The first coding-system used for decoding a MIME entity. +The value is usually nil, and bound to non-nil while inserting +MIME entities.") + ;;; MIME-entity object (defun rmail-mime-entity (type disposition transfer-encoding - header body children) - "Retrun a newly created MIME-entity object. + display header tagline body children handler) + "Retrun a newly created MIME-entity object from arguments. -A MIME-entity is a vector of 6 elements: +A MIME-entity is a vector of 9 elements: - [ TYPE DISPOSITION TRANSFER-ENCODING HEADER BODY CHILDREN ] + [TYPE DISPOSITION TRANSFER-ENCODING DISPLAY HEADER TAGLINE BODY + CHILDREN HANDLER] -TYPE and DISPOSITION correspond to MIME headers Content-Type: and -Cotent-Disposition: respectively, and has this format: +TYPE and DISPOSITION correspond to MIME headers Content-Type and +Cotent-Disposition respectively, and has this format: \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...) @@ -160,31 +180,61 @@ The corresponding TYPE argument must be: 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)) +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: + nil: not displayed + 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 +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. + +CHILDREN is a list of child MIME-entities. A \"multipart/*\" +entity have 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." + (vector type disposition transfer-encoding + display header tagline body children handler)) ;; 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)) +(defsubst rmail-mime-entity-display (entity) (aref entity 3)) +(defsubst rmail-mime-entity-header (entity) (aref entity 4)) +(defsubst rmail-mime-entity-tagline (entity) (aref entity 5)) +(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))) ;;; Buttons (defun rmail-mime-save (button) "Save the attachment using info in the BUTTON." - (let* ((filename (button-get button 'filename)) + (let* ((rmail-mime-mbox-buffer rmail-view-buffer) + (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) @@ -209,7 +259,8 @@ nil for the other types." ;; 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)) + (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") @@ -218,34 +269,293 @@ nil for the other types." (define-button-type 'rmail-mime-save 'action 'rmail-mime-save) +(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 + 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." + (save-excursion + (or entity + (setq entity (get-text-property pos 'rmail-mime-entity))) + (if (not entity) + (vector 1 (point) (point) (point) (point)) + (let ((current (aref (rmail-mime-entity-display entity) 0)) + (beg (if (and (> pos (point-min)) + (eq (get-text-property (1- pos) 'rmail-mime-entity) + entity)) + (previous-single-property-change pos 'rmail-mime-entity + nil (point-min)) + pos)) + (index 1) + tagline-beg body-beg end) + (goto-char beg) + (if (aref current 0) + (search-forward "\n\n" nil t)) + (setq tagline-beg (point)) + (if (>= pos tagline-beg) + (setq index 2)) + (if (aref current 1) + (forward-line 1)) + (setq body-beg (point)) + (if (>= pos body-beg) + (setq index 3)) + (if (aref current 2) + (let ((tag (aref (rmail-mime-entity-tagline entity) 0)) + tag2) + (setq end (next-single-property-change beg 'rmail-mime-entity + nil (point-max))) + (while (and (< end (point-max)) + (setq entity (get-text-property end 'rmail-mime-entity) + tag2 (aref (rmail-mime-entity-tagline entity) 0)) + (and (> (length tag2) 0) + (eq (string-match tag tag2) 0))) + (setq end (next-single-property-change end 'rmail-mime-entity + nil (point-max))))) + (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)))) + +(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))) + (dolist (child (rmail-mime-entity-children entity)) + (rmail-mime-hidden-mode child nil))) + +(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)))) + +(defun rmail-mime-toggle-raw (entity) + "Toggle on and off the raw display mode of MIME-entity ENTITY." + (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)) + ;; 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))))) + +(defun rmail-mime-toggle-hidden () + "Toggle on and off the hidden display mode of MIME-entity ENTITY." + (interactive) + (when (rmail-mime-message-p) + (let* ((rmail-mime-mbox-buffer rmail-view-buffer) + (rmail-mime-view-buffer (current-buffer)) + (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 (aref current 2) + ;; 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). + (if (= (aref segment 0) 3) + (goto-char (aref segment 2))) + (rmail-mime-hidden-mode entity t) + ;; 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)) + (let ((inhibit-read-only t) + (modified (buffer-modified-p)) + (rmail-mime-mbox-buffer rmail-view-buffer) + (rmail-mime-view-buffer rmail-buffer)) + (save-excursion + (goto-char (aref segment 1)) + (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 "\r" 'rmail-mime-toggle-hidden) + ;;; Handlers +(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 +to the tag line." + (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))) + (dolist (item item-list) + (when item + (if (stringp item) + (insert item) + (apply 'insert-button item)))) + (insert "]\n")) + +(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." + (let ((pos (point)) + (last-coding-system-used nil)) + (save-restriction + (narrow-to-region pos pos) + (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 pos (point)) + (if (and last-coding-system-used (not rmail-mime-coding-system)) + (setq rmail-mime-coding-system last-coding-system-used)) + (goto-char (point-min)) + (rmail-highlight-headers) + (goto-char (point-max)) + (insert "\n")))) + (defun rmail-mime-text-handler (content-type content-disposition content-transfer-encoding) "Handle the current buffer as a plain text MIME part." - (let* ((charset (cdr (assq 'charset (cdr content-type)))) - (coding-system (when charset - (intern (downcase charset))))) - (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." + (rmail-mime-insert-text + (rmail-mime-entity content-type content-disposition + content-transfer-encoding + (vector (vector nil nil nil) (vector nil nil t)) + (vector nil nil nil) (vector "" (cons nil nil) t) + (vector nil nil nil) nil 'rmail-mime-insert-text)) + t) + +(defun rmail-mime-insert-decoded-text (entity) + "Decode and insert the text body of MIME-entity ENTITY." (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))))) + (coding-system (if charset + (coding-system-from-name charset))) + (body (rmail-mime-entity-body entity)) + (pos (point))) + (or (and coding-system (coding-system-p coding-system)) + (setq coding-system 'undecided)) + (if (stringp (aref body 0)) + (insert (aref body 0)) + (let ((transfer-encoding (rmail-mime-entity-transfer-encoding entity))) + (insert-buffer-substring rmail-mime-mbox-buffer + (aref body 0) (aref body 1)) + (cond ((string= transfer-encoding "base64") + (ignore-errors (base64-decode-region pos (point)))) + ((string= transfer-encoding "quoted-printable") + (quoted-printable-decode-region pos (point)))))) + (decode-coding-region pos (point) coding-system) + (or rmail-mime-coding-system + (setq rmail-mime-coding-system coding-system)) + (or (bolp) (insert "\n")))) + +(defun rmail-mime-insert-text (entity) + "Presentation handler for a plain text MIME entity." + (let ((current (aref (rmail-mime-entity-display entity) 0)) + (new (aref (rmail-mime-entity-display entity) 1)) + (header (rmail-mime-entity-header entity)) + (tagline (rmail-mime-entity-tagline entity)) + (body (rmail-mime-entity-body entity)) + (beg (point)) + (segment (rmail-mime-entity-segment (point) entity))) + + (or (integerp (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)) + (goto-char (aref segment 2)) + (if (aref current 0) + (delete-char (- (aref segment 2) (aref segment 1)))) + (if (aref new 0) + (rmail-mime-insert-header header))) + ;; tagline + (if (eq (aref current 1) (aref new 1)) + (forward-char (- (aref segment 3) (aref segment 2))) + (if (aref current 1) + (delete-char (- (aref segment 3) (aref segment 2)))) + (if (aref new 1) + (rmail-mime-insert-tagline 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) + (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 () @@ -264,35 +574,35 @@ MIME-Version: 1.0 (set-buffer-multibyte t))) -(defun rmail-mime-insert-image (type 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) - (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)) +(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))) + (bulk-data (aref (rmail-mime-entity-tagline entity) 1)) + (body (rmail-mime-entity-body entity)) + data) + (if (stringp (aref body 0)) + (setq data (aref body 0)) + (let ((rmail-mime-mbox-buffer rmail-view-buffer) + (transfer-encoding (rmail-mime-entity-transfer-encoding entity))) (with-temp-buffer (set-buffer-multibyte nil) (setq buffer-undo-list t) - (insert-buffer-substring mbox-buffer (car body) (cdr body)) + (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)))) (setq data (buffer-substring-no-properties (point-min) (point-max)))))) - (insert-image (create-image data type t)) - (set-buffer-modified-p modified))) + (insert-image (create-image data (cdr bulk-data) t)) + (insert "\n"))) (defun rmail-mime-image (button) "Display the image associated with BUTTON." - (let ((inhibit-read-only t)) - (rmail-mime-insert-image (button-get button 'image-type) - (button-get button 'image-data)))) + (save-excursion + (goto-char (button-end button)) + (rmail-mime-toggle-hidden))) (define-button-type 'rmail-mime-image 'action 'rmail-mime-image) @@ -305,15 +615,60 @@ 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))) + (vector (vector nil nil nil) (vector nil t nil)) + (vector nil nil nil) (vector "" (cons nil nil) t) + (vector nil nil nil) nil 'rmail-mime-insert-bulk))) + +(defun rmail-mime-set-bulk-data (entity) + "Setup the information about the attachment object for MIME-entity ENTITY. +The value is non-nil if and only if the attachment object should be shown +directly." + (let ((content-type (car (rmail-mime-entity-type entity))) + (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) + (cond (size + (setq size (string-to-number size))) + ((stringp (aref body 0)) + (setq size (length (aref body 0)))) + (t + ;; Rough estimation of the size. + (let ((encoding (rmail-mime-entity-transfer-encoding entity))) + (setq size (- (aref body 1) (aref body 0))) + (cond ((string= encoding "base64") + (setq size (/ (* size 3) 4))) + ((string= encoding "quoted-printable") + (setq size (/ (* size 7) 3))))))) + + (cond + ((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) + (image-type-available-p type)) + (if (and rmail-mime-show-images + (not (eq rmail-mime-show-images 'button)) + (or (not (numberp rmail-mime-show-images)) + (< size rmail-mime-show-images))) + (setq to-show t)) + (setq type nil)))) + (setcar bulk-data size) + (setcdr bulk-data type) + to-show)) (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." + "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)) + (new (aref (rmail-mime-entity-display entity) 1)) + (header (rmail-mime-entity-header entity)) + (tagline (rmail-mime-entity-tagline entity)) + (bulk-data (aref tagline 1)) (body (rmail-mime-entity-body entity)) (directory (catch 'directory (dolist (entry rmail-mime-attachment-dirs-alist) @@ -324,47 +679,70 @@ the attachment data that is already decoded." (filename (or (cdr (assq 'name (cdr content-type))) (cdr (assq 'filename (cdr content-disposition))) "noname")) - (label (format "\nAttached %s file: " (car content-type))) (units '(B kB MB GB)) - data udata size osize type) - (if body + (segment (rmail-mime-entity-segment (point) entity)) + beg data size) + + (if (integerp (aref body 0)) (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) + size (car bulk-data)) + (if (stringp (aref body 0)) + (setq data (aref body 0)) + (setq data (string-as-unibyte (buffer-string))) + (aset body 0 data) + (rmail-mime-set-bulk-data entity) + (delete-region (point-min) (point-max))) + (setq size (length data))) (while (and (> size 1024.0) ; cribbed from gnus-agent-expire-done-message (cdr units)) (setq size (/ size 1024.0) units (cdr units))) - (insert label) - (insert-button filename - :type 'rmail-mime-save - 'help-echo "mouse-2, RET: Save attachment" - 'filename filename - 'directory (file-name-as-directory directory) - 'data data) - (insert (format " (%.0f%s)" size (car units))) - (when (and rmail-mime-show-images - (string-match "image/\\(.*\\)" (setq type (car content-type))) - (setq type (concat "." (match-string 1 type)) - type (image-type-from-file-name type)) - (memq type image-types) - (image-type-available-p type)) - (insert " ") - (cond ((or (eq rmail-mime-show-images 'button) - (and (numberp rmail-mime-show-images) - (>= osize rmail-mime-show-images))) - (insert-button "Display" - :type 'rmail-mime-image - 'help-echo "mouse-2, RET: Show image" - 'image-type type - 'image-data udata)) - (t - (rmail-mime-insert-image type udata)))))) + + (setq beg (point)) + + ;; header + (if (eq (aref current 0) (aref new 0)) + (goto-char (aref segment 2)) + (if (aref current 0) + (delete-char (- (aref segment 2) (aref segment 1)))) + (if (aref new 0) + (rmail-mime-insert-header header))) + + ;; tagline + (if (eq (aref current 1) (aref new 1)) + (forward-char (- (aref segment 3) (aref segment 2))) + (if (aref current 1) + (delete-char (- (aref segment 3) (aref segment 2)))) + (if (aref new 1) + (rmail-mime-insert-tagline + entity + " file:" + (list filename + :type 'rmail-mime-save + 'help-echo "mouse-2, RET: Save attachment" + 'filename filename + '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))))) + ;; 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) + (cond ((eq (cdr bulk-data) 'text) + (rmail-mime-insert-decoded-text entity)) + ((cdr bulk-data) + (rmail-mime-insert-image 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." @@ -396,19 +774,21 @@ 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)) + content-type content-disposition content-transfer-encoding nil) + t) (defun rmail-mime-process-multipart (content-type content-disposition content-transfer-encoding - parse-only) + parse-tag) "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. +If PARSE-TAG 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. +Otherwise, PARSE-TAG is a string indicating the depth and index +number of the entity. In this case, 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 @@ -419,6 +799,8 @@ The other arguments are the same as `rmail-mime-multipart-handler'." ;; of the preceding part. ;; We currently don't handle that. (let ((boundary (cdr (assq 'boundary content-type))) + (subtype (cadr (split-string (car content-type) "/"))) + (index 0) beg end next entities) (unless boundary (rmail-mm-get-boundary-error-message @@ -429,12 +811,20 @@ The other arguments are the same as `rmail-mime-multipart-handler'." (goto-char (point-min)) (when (and (search-forward boundary nil t) (looking-at "[ \t]*\n")) - (if parse-only + (if parse-tag (narrow-to-region (match-end 0) (point-max)) (delete-region (point-min) (match-end 0)))) + + ;; Change content-type to the proper default one for the children. + (cond ((string-match "mixed" subtype) + (setq content-type '("text/plain"))) + ((string-match "digest" subtype) + (setq content-type '("message/rfc822")))) + ;; 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. + ;; 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)) @@ -449,17 +839,46 @@ The other arguments are the same as `rmail-mime-multipart-handler'." (rmail-mm-get-boundary-error-message "Malformed boundary" content-type content-disposition content-transfer-encoding))) + + (setq index (1+ index)) ;; Handle the part. - (if parse-only + (if parse-tag (save-restriction (narrow-to-region beg end) - (setq entities (cons (rmail-mime-process nil t) entities))) + (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))) - (nreverse entities))) + + (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) + (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)) + (dolist (child entities) + (or (eq best child) + (rmail-mime-hidden-mode child t))))) + entities))) (defun test-rmail-mime-multipart-handler () "Test of a mail used as an example in RFC 2046." @@ -492,6 +911,40 @@ This is the epilogue. It is also to be ignored.")) (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)) + (new (aref (rmail-mime-entity-display entity) 1)) + (header (rmail-mime-entity-header entity)) + (tagline (rmail-mime-entity-tagline entity)) + (body (rmail-mime-entity-body entity)) + (beg (point)) + (segment (rmail-mime-entity-segment (point) entity))) + ;; header + (if (eq (aref current 0) (aref new 0)) + (goto-char (aref segment 2)) + (if (aref current 0) + (delete-char (- (aref segment 2) (aref segment 1)))) + (if (aref new 0) + (rmail-mime-insert-header header))) + ;; tagline + (if (eq (aref current 1) (aref new 1)) + (forward-char (- (aref segment 3) (aref segment 2))) + (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)))))) + ;;; Main code (defun rmail-mime-handle (content-type @@ -564,7 +1017,9 @@ 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) +(defun rmail-mime-process (show-headers parse-tag &optional + default-content-type + default-content-disposition) (let ((end (point-min)) content-type content-transfer-encoding @@ -595,45 +1050,76 @@ modified." (setq content-type (if content-type (mail-header-parse-content-type content-type) - ;; FIXME: Default "message/rfc822" in a "multipart/digest" - ;; according to RFC 2046. - '("text/plain"))) + (or default-content-type '("text/plain")))) (setq content-disposition (if content-disposition (mail-header-parse-content-disposition content-disposition) ;; If none specified, we are free to choose what we deem ;; suitable according to RFC 2183. We like inline. - '("inline"))) + (or default-content-disposition '("inline")))) ;; Unrecognized disposition types are to be treated like ;; attachment according to RFC 2183. (unless (member (car content-disposition) '("inline" "attachment")) (setq content-disposition '("attachment"))) - (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)))) + (if parse-tag + (let* ((is-inline (string= (car content-disposition) "inline")) + (header (vector (point-min) end nil)) + (tagline (vector parse-tag (cons nil nil) t)) + (body (vector end (point-max) 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)) + (setq children (rmail-mime-process-multipart + content-type + content-disposition + content-transfer-encoding + parse-tag) + handler 'rmail-mime-insert-multipart))) + ((string-match "message/rfc822" (car content-type)) + (save-restriction (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))) + (let* ((msg (rmail-mime-process t parse-tag + '("text/plain") '("inline"))) + (msg-new (aref (rmail-mime-entity-display msg) 1))) + ;; Show header of the child. + (aset msg-new 0 t) + (aset (rmail-mime-entity-header msg) 2 t) + ;; Hide tagline of the child. + (aset msg-new 1 nil) + (aset (rmail-mime-entity-tagline msg) 2 nil) + (setq children (list msg) + handler 'rmail-mime-insert-multipart)))) + ((and is-inline (string-match "text/" (car content-type))) + ;; Don't need a tagline. + (aset new 1 (aset tagline 2 nil)) + (setq handler 'rmail-mime-insert-text)) + (t + ;; Force hidden mode. + (aset new 1 (aset tagline 2 t)) + (aset new 2 (aset body 2 nil)) + (setq handler 'rmail-mime-insert-bulk))) + (setq entity (rmail-mime-entity content-type + content-disposition + content-transfer-encoding + (vector (vector nil nil nil) new) + header tagline body children handler)) + (if (and (eq handler 'rmail-mime-insert-bulk) + (rmail-mime-set-bulk-data entity)) + ;; Show the body. + (aset new 2 (aset body 2 t))) + entity) + ;; 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)) (save-restriction (cond ((string= (car content-type) "message/rfc822") (narrow-to-region end (point-max))) @@ -642,102 +1128,117 @@ modified." (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 of them. - (dolist (child children) - (rmail-mime-insert 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)) - (condition-case nil - (rmail-mime-process nil t) - (error nil)))) - -(defun rmail-mime-insert (entity &optional content-type disposition) +The value is a MIME-entiy object (see `rmail-mime-entity')." + (let ((rmail-mime-mbox-buffer (if (rmail-buffers-swapped-p) + rmail-view-buffer + (current-buffer)))) + ;;(condition-case err + (with-current-buffer rmail-mime-mbox-buffer + (save-excursion + (goto-char (point-min)) + (let* ((entity (rmail-mime-process t "" + '("text/plain") '("inline"))) + (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 (error (format "%s" err)))) + )) + +(defun rmail-mime-insert (entity) "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)))) + (let ((current (aref (rmail-mime-entity-display entity) 0)) + (new (aref (rmail-mime-entity-display entity) 1))) + (if (not (eq (aref new 0) 'raw)) + ;; Not a raw-mode. Each handler should handle it. + (funcall (rmail-mime-entity-handler entity) entity) + (let ((header (rmail-mime-entity-header entity)) + (tagline (rmail-mime-entity-tagline entity)) + (body (rmail-mime-entity-body entity)) + (beg (point)) + (segment (rmail-mime-entity-segment (point) entity))) + ;; header + (if (eq (aref current 0) (aref new 0)) + (goto-char (aref segment 2)) + (if (aref current 0) + (delete-char (- (aref segment 2) (aref segment 1)))) + (insert-buffer-substring rmail-mime-mbox-buffer + (aref header 0) (aref header 1))) + ;; tagline + (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))) + (dotimes (i 3) + (aset current i (aref new i))))) (define-derived-mode rmail-mime-mode fundamental-mode "RMIME" "Major mode used in `rmail-mime' buffers." (setq font-lock-defaults '(rmail-font-lock-keywords t t nil nil))) ;;;###autoload -(defun rmail-mime () - "Process the current Rmail message as a MIME message. -This creates a temporary \"*RMAIL*\" buffer holding a decoded -copy of the message. Inline content-types are handled according to +(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) - (let ((data (rmail-apply-in-message rmail-current-message 'buffer-string)) - (buf (get-buffer-create "*RMAIL*"))) - (set-buffer buf) - (setq buffer-undo-list t) - (let ((inhibit-read-only t)) - ;; Decoding the message in fundamental mode for speed, only - ;; switching to rmail-mime-mode at the end for display. Eg - ;; quoted-printable-decode-region gets very slow otherwise (Bug#4993). - (fundamental-mode) - (erase-buffer) - (insert data) - (rmail-mime-show t) - (rmail-mime-mode) - (set-buffer-modified-p nil)) - (view-buffer buf))) + (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")) + (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-view-buffer buf)) + (set-buffer buf) + (setq buffer-undo-list t) + (let ((inhibit-read-only t)) + ;; Decoding the message in fundamental mode for speed, only + ;; switching to rmail-mime-mode at the end for display. Eg + ;; quoted-printable-decode-region gets very slow otherwise (Bug#4993). + (fundamental-mode) + (erase-buffer) + (insert data) + (rmail-mime-show t) + (rmail-mime-mode) + (set-buffer-modified-p nil)) + (view-buffer buf)))) (defun rmail-mm-get-boundary-error-message (message type disposition encoding) "Return MESSAGE with more information on the main mime components." @@ -746,34 +1247,39 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'." (defun rmail-show-mime () "Function to set in `rmail-show-mime-function' (which see)." - (let ((mbox-buf rmail-buffer) - (entity (rmail-mime-parse))) + (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 - (with-current-buffer rmail-view-buffer - (let ((inhibit-read-only t) - (rmail-buffer mbox-buf)) - (erase-buffer) - (rmail-mime-insert 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. - (let ((region (with-current-buffer mbox-buf + (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))))) - (with-current-buffer rmail-view-buffer + (with-current-buffer rmail-mime-view-buffer (let ((inhibit-read-only t)) (erase-buffer) - (insert-buffer-substring mbox-buf (car region) (cdr region)))) + (insert-buffer-substring rmail-mime-mbox-buffer + (car region) (cdr region)))) + (set-buffer-file-coding-system 'no-conversion t t) (message "MIME decoding failed"))))) (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 ((mbox-buf (with-current-buffer forward-buffer rmail-view-buffer))) + (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 mbox-buf)))) + (message-forward-make-body-mime rmail-mime-mbox-buffer)))) (setq rmail-insert-mime-forwarded-message-function 'rmail-insert-mime-forwarded-message) @@ -794,15 +1300,16 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'." "Function to set in `rmail-search-mime-message-function' (which see)." (save-restriction (narrow-to-region (rmail-msgbeg msg) (rmail-msgend msg)) - (let ((mbox-buf (current-buffer)) - (header-end (save-excursion - (re-search-forward "^$" nil 'move) (point))) - (body-end (point-max)) - (entity (rmail-mime-parse))) + (let* ((rmail-mime-mbox-buffer (current-buffer)) + (rmail-mime-view-buffer rmail-view-buffer) + (header-end (save-excursion + (re-search-forward "^$" nil 'move) (point))) + (body-end (point-max)) + (entity (rmail-mime-parse))) (or ;; At first, just search the headers. (with-temp-buffer - (insert-buffer-substring mbox-buf nil header-end) + (insert-buffer-substring rmail-mime-mbox-buffer nil header-end) (rfc2047-decode-region (point-min) (point)) (goto-char (point-min)) (re-search-forward regexp nil t)) @@ -815,8 +1322,7 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'." (not (string= (downcase charset) "us-ascii")))))) ;; Search the decoded MIME message. (with-temp-buffer - (let ((rmail-buffer mbox-buf)) - (rmail-mime-insert entity)) + (rmail-mime-insert entity) (goto-char (point-min)) (re-search-forward regexp nil t)) ;; Search the body without decoding. -- 2.39.2