Mercurial > emacs
changeset 112062:34341d09c440
Enable display mode of MIME message in rmail.
| author | Kenichi Handa <handa@m17n.org> |
|---|---|
| date | Fri, 24 Dec 2010 13:38:22 +0900 |
| parents | 2b8e51d977c3 |
| children | 4bb564da3320 4c862bc17cdb |
| files | etc/NEWS lisp/ChangeLog lisp/mail/rmail.el lisp/mail/rmailmm.el |
| diffstat | 4 files changed, 876 insertions(+), 299 deletions(-) [+] |
line wrap: on
line diff
--- a/etc/NEWS Fri Dec 24 11:30:43 2010 +0900 +++ b/etc/NEWS Fri Dec 24 13:38:22 2010 +0900 @@ -72,6 +72,27 @@ 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 +++
--- a/lisp/ChangeLog Fri Dec 24 11:30:43 2010 +0900 +++ b/lisp/ChangeLog Fri Dec 24 13:38:22 2010 +0900 @@ -1,3 +1,46 @@ +2010-12-24 Kenichi Handa <handa@m17n.org> + + * 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 <sdl.web@gmail.com> * help-fns.el (describe-variable): Fix 2010-12-17 change.
--- a/lisp/mail/rmail.el Fri Dec 24 11:30:43 2010 +0900 +++ b/lisp/mail/rmail.el Fri Dec 24 13:38:22 2010 +0900 @@ -2691,75 +2691,72 @@ (message "Showing message %d" msg)) (narrow-to-region beg end) (goto-char beg) + (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)) (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; + (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 @@ ;;;*** -;;;### (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) ;;;***
--- a/lisp/mail/rmailmm.el Fri Dec 24 11:30:43 2010 +0900 +++ b/lisp/mail/rmailmm.el Fri Dec 24 13:38:22 2010 +0900 @@ -96,7 +96,9 @@ 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 @@ ;;; 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 @@ 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. +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) -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)) +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 @@ ;; 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 @@ (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)))) + (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-text (entity) - "Insert MIME-entity ENTITY as a plain text MIME part in the current buffer." +(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 @@ (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 @@ 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 @@ (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 @@ 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 @@ ;; 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 @@ (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 @@ (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 @@ (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 @@ 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 @@ (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 @@ (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)))) +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 &optional content-type disposition) +(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 @@ (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 @@ "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 @@ (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.