diff options
| author | Kenichi Handa | 2010-12-24 13:38:22 +0900 |
|---|---|---|
| committer | Kenichi Handa | 2010-12-24 13:38:22 +0900 |
| commit | 186f7f0b7f48751df956707de5476e63ca4c1dbe (patch) | |
| tree | d6d4a58a62dba7bcad84319902189080fb6452d0 | |
| parent | e1a235757a06328c5262c19e37e89428b32571ae (diff) | |
| download | emacs-186f7f0b7f48751df956707de5476e63ca4c1dbe.tar.gz emacs-186f7f0b7f48751df956707de5476e63ca4c1dbe.zip | |
Enable display mode of MIME message in rmail.
| -rw-r--r-- | etc/NEWS | 21 | ||||
| -rw-r--r-- | lisp/ChangeLog | 43 | ||||
| -rw-r--r-- | lisp/mail/rmail.el | 137 | ||||
| -rw-r--r-- | lisp/mail/rmailmm.el | 980 |
4 files changed, 879 insertions, 302 deletions
| @@ -72,6 +72,27 @@ Bazaar recognizes the headers "Author", "Date" and "Fixes". | |||
| 72 | Git, Mercurial, and Monotone recognize "Author" and "Date". | 72 | Git, Mercurial, and Monotone recognize "Author" and "Date". |
| 73 | Any unknown header is left as is in the message, so it is not lost. | 73 | Any unknown header is left as is in the message, so it is not lost. |
| 74 | 74 | ||
| 75 | ** Rmail | ||
| 76 | |||
| 77 | ** The default value of `rmail-enable-mime' is now t. Rmail decodes | ||
| 78 | MIME contents automatically. You can customize the variable | ||
| 79 | `rmail-enable-mime' back to `nil' to disable this automatic MIME | ||
| 80 | decoding. | ||
| 81 | |||
| 82 | ** The command `rmail-mime' change the displaying of a MIME message | ||
| 83 | between decoded presentation form and raw data if `rmail-enable-mime' | ||
| 84 | is non-nil. And, with prefix argument, it change only the displaying | ||
| 85 | of the MIME entity at point. | ||
| 86 | |||
| 87 | ** The new command TAB (rmail-mime-next-item) moves point to the next | ||
| 88 | item of MIME message. | ||
| 89 | |||
| 90 | ** The new command backtab (rmail-mime-previous-item) moves point to | ||
| 91 | the previous item of MIME message. | ||
| 92 | |||
| 93 | ** The new command RET (rmail-mime-toggle-hidden) hide or show the | ||
| 94 | body of the MIME entity at point. | ||
| 95 | |||
| 75 | ** Obsolete packages | 96 | ** Obsolete packages |
| 76 | 97 | ||
| 77 | +++ | 98 | +++ |
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index dcdfa3ebc88..ee6848449c7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog | |||
| @@ -1,3 +1,46 @@ | |||
| 1 | 2010-12-24 Kenichi Handa <handa@m17n.org> | ||
| 2 | |||
| 3 | * mail/rmailmm.el: New key bindings for rmail-mime-next-item, | ||
| 4 | rmail-mime-previous-item, and rmail-mime-toggle-hidden. | ||
| 5 | (rmail-mime-mbox-buffer) | ||
| 6 | (rmail-mime-view-buffer, rmail-mime-coding-system): New variables. | ||
| 7 | (rmail-mime-entity): Argument changed. All codes handling an | ||
| 8 | entity object are changed. | ||
| 9 | (rmail-mime-entity-header, rmail-mime-entity-body): Adjusted for | ||
| 10 | the above change. | ||
| 11 | (rmail-mime-entity-children, rmail-mime-entity-handler) | ||
| 12 | (rmail-mime-entity-tagline): New functions. | ||
| 13 | (rmail-mime-message-p): New function. | ||
| 14 | (rmail-mime-save): Bind rmail-mime-mbox-buffer. | ||
| 15 | (rmail-mime-entity-segment, rmail-mime-next-item) | ||
| 16 | (rmail-mime-previous-item, rmail-mime-shown-mode) | ||
| 17 | (rmail-mime-hidden-mode, rmail-mime-raw-mode) | ||
| 18 | (rmail-mime-toggle-raw, rmail-mime-toggle-hidden) | ||
| 19 | (rmail-mime-insert-tagline, rmail-mime-insert-header): New | ||
| 20 | functions. | ||
| 21 | (rmail-mime-text-handler): Call rmail-mime-insert-text. | ||
| 22 | (rmail-mime-insert-decoded-text): New function. | ||
| 23 | (rmail-mime-insert-text): Call rmail-mime-insert-decoded-text. | ||
| 24 | (rmail-mime-insert-image): Argument changed. Caller changed. | ||
| 25 | (rmail-mime-image): Call rmail-mime-toggle-hidden. | ||
| 26 | (rmail-mime-set-bulk-data): New funciton. | ||
| 27 | (rmail-mime-insert-bulk): Argument changed. | ||
| 28 | (rmail-mime-multipart-handler): Return t. | ||
| 29 | (rmail-mime-process-multipart): Argument changed. Handle | ||
| 30 | "multipart/alternative" here. | ||
| 31 | (rmail-mime-process): Argument changed. | ||
| 32 | (rmail-mime-parse): Bind rmail-mime-mbox-buffer. | ||
| 33 | (rmail-mime-insert): Argument changed. Handle raw display mode. | ||
| 34 | (rmail-mime): Argument changed. Handle toggling of raw display | ||
| 35 | mode. | ||
| 36 | (rmail-show-mime): Bind rmail-mime-mbox-buffer and | ||
| 37 | rmail-mime-view-buffer. | ||
| 38 | (rmail-insert-mime-forwarded-message): Likewise. | ||
| 39 | (rmail-search-mime-message): Likewise. Don't bind rmail-buffer. | ||
| 40 | |||
| 41 | * mail/rmail.el (rmail-show-message-1): If rmail-enable-mime is | ||
| 42 | non-nil, handle the header in rmail-show-mime-function. | ||
| 43 | |||
| 1 | 2010-12-20 Leo <sdl.web@gmail.com> | 44 | 2010-12-20 Leo <sdl.web@gmail.com> |
| 2 | 45 | ||
| 3 | * help-fns.el (describe-variable): Fix 2010-12-17 change. | 46 | * 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." | |||
| 2691 | (message "Showing message %d" msg)) | 2691 | (message "Showing message %d" msg)) |
| 2692 | (narrow-to-region beg end) | 2692 | (narrow-to-region beg end) |
| 2693 | (goto-char beg) | 2693 | (goto-char beg) |
| 2694 | (if (and rmail-enable-mime | ||
| 2695 | (re-search-forward "mime-version: 1.0" nil t)) | ||
| 2696 | (let ((rmail-buffer mbox-buf) | ||
| 2697 | (rmail-view-buffer view-buf)) | ||
| 2698 | (funcall rmail-show-mime-function)) | ||
| 2699 | (setq body-start (search-forward "\n\n" nil t)) | ||
| 2700 | (narrow-to-region beg (point)) | ||
| 2701 | (goto-char beg) | ||
| 2702 | (save-excursion | ||
| 2703 | (if (re-search-forward "^X-Coding-System: *\\(.*\\)$" nil t) | ||
| 2704 | (setq coding-system (intern (match-string 1))) | ||
| 2705 | (setq coding-system (rmail-get-coding-system)))) | ||
| 2706 | (setq character-coding (mail-fetch-field "content-transfer-encoding") | ||
| 2707 | is-text-message (rmail-is-text-p)) | ||
| 2708 | (if character-coding | ||
| 2709 | (setq character-coding (downcase character-coding))) | ||
| 2710 | (narrow-to-region beg end) | ||
| 2711 | ;; Decode the message body into an empty view buffer using a | ||
| 2712 | ;; unibyte temporary buffer where the character decoding takes | ||
| 2713 | ;; place. | ||
| 2714 | (with-current-buffer rmail-view-buffer | ||
| 2715 | (erase-buffer)) | ||
| 2716 | (if (null character-coding) | ||
| 2717 | ;; Do it directly since that is fast. | ||
| 2718 | (rmail-decode-region body-start end coding-system view-buf) | ||
| 2719 | ;; Can this be done directly, skipping the temp buffer? | ||
| 2720 | (with-temp-buffer | ||
| 2721 | (set-buffer-multibyte nil) | ||
| 2722 | (insert-buffer-substring mbox-buf body-start end) | ||
| 2723 | (cond | ||
| 2724 | ((string= character-coding "quoted-printable") | ||
| 2725 | ;; See bug#5441. | ||
| 2726 | (or (mail-unquote-printable-region (point-min) (point-max) | ||
| 2727 | nil t 'unibyte) | ||
| 2728 | (message "Malformed MIME quoted-printable message"))) | ||
| 2729 | ((and (string= character-coding "base64") is-text-message) | ||
| 2730 | (condition-case err | ||
| 2731 | (base64-decode-region (point-min) (point-max)) | ||
| 2732 | (error (message "%s" (cdr err))))) | ||
| 2733 | ((eq character-coding 'uuencode) | ||
| 2734 | (error "uuencoded messages are not supported yet")) | ||
| 2735 | (t)) | ||
| 2736 | (rmail-decode-region (point-min) (point-max) | ||
| 2737 | coding-system view-buf)))) | ||
| 2738 | (with-current-buffer rmail-view-buffer | 2694 | (with-current-buffer rmail-view-buffer |
| 2739 | ;; We give the view buffer a buffer-local value of | 2695 | ;; We give the view buffer a buffer-local value of |
| 2740 | ;; rmail-header-style based on the binding in effect when | 2696 | ;; rmail-header-style based on the binding in effect when |
| 2741 | ;; this function is called; `rmail-toggle-headers' can | 2697 | ;; this function is called; `rmail-toggle-headers' can |
| 2742 | ;; inspect this value to determine how to toggle. | 2698 | ;; inspect this value to determine how to toggle. |
| 2743 | (set (make-local-variable 'rmail-header-style) header-style) | 2699 | (set (make-local-variable 'rmail-header-style) header-style)) |
| 2744 | ;; Unquote quoted From lines | 2700 | (if (and rmail-enable-mime |
| 2745 | (goto-char (point-min)) | 2701 | (re-search-forward "mime-version: 1.0" nil t)) |
| 2746 | (while (re-search-forward "^>+From " nil t) | 2702 | (let ((rmail-buffer mbox-buf) |
| 2747 | (beginning-of-line) | 2703 | (rmail-view-buffer view-buf)) |
| 2748 | (delete-char 1) | 2704 | (funcall rmail-show-mime-function)) |
| 2749 | (forward-line)) | 2705 | (setq body-start (search-forward "\n\n" nil t)) |
| 2750 | (goto-char (point-min))) | 2706 | (narrow-to-region beg (point)) |
| 2751 | ;; Copy the headers to the front of the message view buffer. | 2707 | (goto-char beg) |
| 2752 | (rmail-copy-headers beg end) | 2708 | (save-excursion |
| 2753 | ;; Add the separator (blank line) between headers and body; | 2709 | (if (re-search-forward "^X-Coding-System: *\\(.*\\)$" nil t) |
| 2710 | (setq coding-system (intern (match-string 1))) | ||
| 2711 | (setq coding-system (rmail-get-coding-system)))) | ||
| 2712 | (setq character-coding (mail-fetch-field "content-transfer-encoding") | ||
| 2713 | is-text-message (rmail-is-text-p)) | ||
| 2714 | (if character-coding | ||
| 2715 | (setq character-coding (downcase character-coding))) | ||
| 2716 | (narrow-to-region beg end) | ||
| 2717 | ;; Decode the message body into an empty view buffer using a | ||
| 2718 | ;; unibyte temporary buffer where the character decoding takes | ||
| 2719 | ;; place. | ||
| 2720 | (with-current-buffer rmail-view-buffer | ||
| 2721 | (erase-buffer)) | ||
| 2722 | (if (null character-coding) | ||
| 2723 | ;; Do it directly since that is fast. | ||
| 2724 | (rmail-decode-region body-start end coding-system view-buf) | ||
| 2725 | ;; Can this be done directly, skipping the temp buffer? | ||
| 2726 | (with-temp-buffer | ||
| 2727 | (set-buffer-multibyte nil) | ||
| 2728 | (insert-buffer-substring mbox-buf body-start end) | ||
| 2729 | (cond | ||
| 2730 | ((string= character-coding "quoted-printable") | ||
| 2731 | ;; See bug#5441. | ||
| 2732 | (or (mail-unquote-printable-region (point-min) (point-max) | ||
| 2733 | nil t 'unibyte) | ||
| 2734 | (message "Malformed MIME quoted-printable message"))) | ||
| 2735 | ((and (string= character-coding "base64") is-text-message) | ||
| 2736 | (condition-case err | ||
| 2737 | (base64-decode-region (point-min) (point-max)) | ||
| 2738 | (error (message "%s" (cdr err))))) | ||
| 2739 | ((eq character-coding 'uuencode) | ||
| 2740 | (error "uuencoded messages are not supported yet")) | ||
| 2741 | (t)) | ||
| 2742 | (rmail-decode-region (point-min) (point-max) | ||
| 2743 | coding-system view-buf))) | ||
| 2744 | (with-current-buffer rmail-view-buffer | ||
| 2745 | ;; Prepare the separator (blank line) before the body. | ||
| 2746 | (goto-char (point-min)) | ||
| 2747 | (insert "\n") | ||
| 2748 | ;; Unquote quoted From lines | ||
| 2749 | (while (re-search-forward "^>+From " nil t) | ||
| 2750 | (beginning-of-line) | ||
| 2751 | (delete-char 1) | ||
| 2752 | (forward-line)) | ||
| 2753 | (goto-char (point-min))) | ||
| 2754 | ;; Copy the headers to the front of the message view buffer. | ||
| 2755 | (rmail-copy-headers beg end)) | ||
| 2754 | ;; highlight the message, activate any URL like text and add | 2756 | ;; highlight the message, activate any URL like text and add |
| 2755 | ;; special highlighting for and quoted material. | 2757 | ;; special highlighting for and quoted material. |
| 2756 | (with-current-buffer rmail-view-buffer | 2758 | (with-current-buffer rmail-view-buffer |
| 2757 | (insert "\n") | ||
| 2758 | (goto-char (point-min)) | 2759 | (goto-char (point-min)) |
| 2759 | ;; Decode the headers according to RFC2047. | ||
| 2760 | (save-excursion | ||
| 2761 | (search-forward "\n\n" nil 'move) | ||
| 2762 | (rfc2047-decode-region (point-min) (point))) | ||
| 2763 | (rmail-highlight-headers) | 2760 | (rmail-highlight-headers) |
| 2764 | ;(rmail-activate-urls) | 2761 | ;(rmail-activate-urls) |
| 2765 | ;(rmail-process-quoted-material) | 2762 | ;(rmail-process-quoted-material) |
| @@ -4290,18 +4287,28 @@ With prefix argument N moves forward N messages with these labels. | |||
| 4290 | 4287 | ||
| 4291 | ;;;*** | 4288 | ;;;*** |
| 4292 | 4289 | ||
| 4293 | ;;;### (autoloads (rmail-mime) "rmailmm" "rmailmm.el" "222ca7c1e672a08e5799e5a72fb25049") | 4290 | ;;;### (autoloads (rmail-mime) "rmailmm" "rmailmm.el" "faa9e26c7781c426785e671a040128ad") |
| 4294 | ;;; Generated autoloads from rmailmm.el | 4291 | ;;; Generated autoloads from rmailmm.el |
| 4295 | 4292 | ||
| 4296 | (autoload 'rmail-mime "rmailmm" "\ | 4293 | (autoload 'rmail-mime "rmailmm" "\ |
| 4297 | Process the current Rmail message as a MIME message. | 4294 | Toggle displaying of a MIME message. |
| 4298 | This creates a temporary \"*RMAIL*\" buffer holding a decoded | 4295 | |
| 4299 | copy of the message. Inline content-types are handled according to | 4296 | The actualy behavior depends on the value of `rmail-enable-mime'. |
| 4297 | |||
| 4298 | If `rmail-enable-mime' is t (default), this command change the | ||
| 4299 | displaying of a MIME message between decoded presentation form | ||
| 4300 | and raw data. | ||
| 4301 | |||
| 4302 | With ARG, toggle the displaying of the current MIME entity only. | ||
| 4303 | |||
| 4304 | If `rmail-enable-mime' is nil, this creates a temporary | ||
| 4305 | \"*RMAIL*\" buffer holding a decoded copy of the message. Inline | ||
| 4306 | content-types are handled according to | ||
| 4300 | `rmail-mime-media-type-handlers-alist'. By default, this | 4307 | `rmail-mime-media-type-handlers-alist'. By default, this |
| 4301 | displays text and multipart messages, and offers to download | 4308 | displays text and multipart messages, and offers to download |
| 4302 | attachments as specfied by `rmail-mime-attachment-dirs-alist'. | 4309 | attachments as specfied by `rmail-mime-attachment-dirs-alist'. |
| 4303 | 4310 | ||
| 4304 | \(fn)" t nil) | 4311 | \(fn &optional ARG)" t nil) |
| 4305 | 4312 | ||
| 4306 | ;;;*** | 4313 | ;;;*** |
| 4307 | 4314 | ||
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. | |||
| 96 | The remaining elements are handler functions to run, in order of | 96 | The remaining elements are handler functions to run, in order of |
| 97 | decreasing preference. These are called until one returns non-nil. | 97 | decreasing preference. These are called until one returns non-nil. |
| 98 | Note that this only applies to items with an inline Content-Disposition, | 98 | Note that this only applies to items with an inline Content-Disposition, |
| 99 | all others are handled by `rmail-mime-bulk-handler'." | 99 | all others are handled by `rmail-mime-bulk-handler'. |
| 100 | Note also that this alist is ignored when the variable | ||
| 101 | `rmail-enable-mime' is non-nil." | ||
| 100 | :type '(alist :key-type regexp :value-type (repeat function)) | 102 | :type '(alist :key-type regexp :value-type (repeat function)) |
| 101 | :version "23.1" | 103 | :version "23.1" |
| 102 | :group 'rmail-mime) | 104 | :group 'rmail-mime) |
| @@ -130,18 +132,36 @@ automatically display the image in the buffer." | |||
| 130 | 132 | ||
| 131 | ;;; End of user options. | 133 | ;;; End of user options. |
| 132 | 134 | ||
| 135 | ;;; Global variables that always have let-binding when referred. | ||
| 136 | |||
| 137 | (defvar rmail-mime-mbox-buffer nil | ||
| 138 | "Buffer containing the mbox data. | ||
| 139 | The value is usually nil, and bound to a proper value while | ||
| 140 | processing MIME.") | ||
| 141 | |||
| 142 | (defvar rmail-mime-view-buffer nil | ||
| 143 | "Buffer showing a message. | ||
| 144 | The value is usually nil, and bound to a proper value while | ||
| 145 | processing MIME.") | ||
| 146 | |||
| 147 | (defvar rmail-mime-coding-system nil | ||
| 148 | "The first coding-system used for decoding a MIME entity. | ||
| 149 | The value is usually nil, and bound to non-nil while inserting | ||
| 150 | MIME entities.") | ||
| 151 | |||
| 133 | ;;; MIME-entity object | 152 | ;;; MIME-entity object |
| 134 | 153 | ||
| 135 | (defun rmail-mime-entity (type disposition transfer-encoding | 154 | (defun rmail-mime-entity (type disposition transfer-encoding |
| 136 | header body children) | 155 | display header tagline body children handler) |
| 137 | "Retrun a newly created MIME-entity object. | 156 | "Retrun a newly created MIME-entity object from arguments. |
| 138 | 157 | ||
| 139 | A MIME-entity is a vector of 6 elements: | 158 | A MIME-entity is a vector of 9 elements: |
| 140 | 159 | ||
| 141 | [ TYPE DISPOSITION TRANSFER-ENCODING HEADER BODY CHILDREN ] | 160 | [TYPE DISPOSITION TRANSFER-ENCODING DISPLAY HEADER TAGLINE BODY |
| 161 | CHILDREN HANDLER] | ||
| 142 | 162 | ||
| 143 | TYPE and DISPOSITION correspond to MIME headers Content-Type: and | 163 | TYPE and DISPOSITION correspond to MIME headers Content-Type and |
| 144 | Cotent-Disposition: respectively, and has this format: | 164 | Cotent-Disposition respectively, and has this format: |
| 145 | 165 | ||
| 146 | \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...) | 166 | \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...) |
| 147 | 167 | ||
| @@ -160,31 +180,61 @@ The corresponding TYPE argument must be: | |||
| 160 | TRANSFER-ENCODING corresponds to MIME header | 180 | TRANSFER-ENCODING corresponds to MIME header |
| 161 | Content-Transfer-Encoding, and is a lowercased string. | 181 | Content-Transfer-Encoding, and is a lowercased string. |
| 162 | 182 | ||
| 163 | HEADER and BODY are a cons (BEG . END), where BEG and END specify | 183 | DISPLAY is a vector [CURRENT NEW], where CURRENT indicates how |
| 164 | the region of the corresponding part in RMAIL's data (mbox) | 184 | the header, tagline, and body of the entity are displayed now, |
| 165 | buffer. BODY may be nil. In that case, the current buffer is | 185 | and NEW indicates how their displaying should be updated. |
| 166 | narrowed to the body part. | 186 | Both elements are vector [HEADER-DISPLAY TAGLINE-DISPLAY BODY-DISPLAY], |
| 167 | 187 | where each element is a symbol for the corresponding item that | |
| 168 | CHILDREN is a list of MIME-entities for a \"multipart\" entity, and | 188 | has these values: |
| 169 | nil for the other types." | 189 | nil: not displayed |
| 170 | (vector type disposition transfer-encoding header body children)) | 190 | t: displayed by the decoded presentation form |
| 191 | raw: displayed by the raw MIME data (for the header and body only) | ||
| 192 | |||
| 193 | HEADER and BODY are vectors [BEG END DISPLAY-FLAG], where BEG and | ||
| 194 | END specify the region of the header or body lines in RMAIL's | ||
| 195 | data (mbox) buffer, and DISPLAY-FLAG non-nil means that the | ||
| 196 | header or body is, by default, displayed by the decoded | ||
| 197 | presentation form. | ||
| 198 | |||
| 199 | TAGLINE is a vector [TAG BULK-DATA DISPLAY-FLAG], where TAG is a | ||
| 200 | string indicating the depth and index number of the entity, | ||
| 201 | BULK-DATA is a cons (SIZE . TYPE) indicating the size and type of | ||
| 202 | an attached data, DISPLAY-FLAG non-nil means that the tagline is, | ||
| 203 | by default, displayed. | ||
| 204 | |||
| 205 | CHILDREN is a list of child MIME-entities. A \"multipart/*\" | ||
| 206 | entity have one or more children. A \"message/rfc822\" entity | ||
| 207 | has just one child. Any other entity has no child. | ||
| 208 | |||
| 209 | HANDLER is a function to insert the entity according to DISPLAY. | ||
| 210 | It is called with one argument ENTITY." | ||
| 211 | (vector type disposition transfer-encoding | ||
| 212 | display header tagline body children handler)) | ||
| 171 | 213 | ||
| 172 | ;; Accessors for a MIME-entity object. | 214 | ;; Accessors for a MIME-entity object. |
| 173 | (defsubst rmail-mime-entity-type (entity) (aref entity 0)) | 215 | (defsubst rmail-mime-entity-type (entity) (aref entity 0)) |
| 174 | (defsubst rmail-mime-entity-disposition (entity) (aref entity 1)) | 216 | (defsubst rmail-mime-entity-disposition (entity) (aref entity 1)) |
| 175 | (defsubst rmail-mime-entity-transfer-encoding (entity) (aref entity 2)) | 217 | (defsubst rmail-mime-entity-transfer-encoding (entity) (aref entity 2)) |
| 176 | (defsubst rmail-mime-entity-header (entity) (aref entity 3)) | 218 | (defsubst rmail-mime-entity-display (entity) (aref entity 3)) |
| 177 | (defsubst rmail-mime-entity-body (entity) (aref entity 4)) | 219 | (defsubst rmail-mime-entity-header (entity) (aref entity 4)) |
| 178 | (defsubst rmail-mime-entity-children (entity) (aref entity 5)) | 220 | (defsubst rmail-mime-entity-tagline (entity) (aref entity 5)) |
| 221 | (defsubst rmail-mime-entity-body (entity) (aref entity 6)) | ||
| 222 | (defsubst rmail-mime-entity-children (entity) (aref entity 7)) | ||
| 223 | (defsubst rmail-mime-entity-handler (entity) (aref entity 8)) | ||
| 224 | |||
| 225 | (defsubst rmail-mime-message-p () | ||
| 226 | "Non-nil if and only if the current message is a MIME." | ||
| 227 | (or (get-text-property (point) 'rmail-mime-entity) | ||
| 228 | (get-text-property (point-min) 'rmail-mime-entity))) | ||
| 179 | 229 | ||
| 180 | ;;; Buttons | 230 | ;;; Buttons |
| 181 | 231 | ||
| 182 | (defun rmail-mime-save (button) | 232 | (defun rmail-mime-save (button) |
| 183 | "Save the attachment using info in the BUTTON." | 233 | "Save the attachment using info in the BUTTON." |
| 184 | (let* ((filename (button-get button 'filename)) | 234 | (let* ((rmail-mime-mbox-buffer rmail-view-buffer) |
| 235 | (filename (button-get button 'filename)) | ||
| 185 | (directory (button-get button 'directory)) | 236 | (directory (button-get button 'directory)) |
| 186 | (data (button-get button 'data)) | 237 | (data (button-get button 'data)) |
| 187 | (mbox-buf rmail-view-buffer) | ||
| 188 | (ofilename filename)) | 238 | (ofilename filename)) |
| 189 | (setq filename (expand-file-name | 239 | (setq filename (expand-file-name |
| 190 | (read-file-name (format "Save as (default: %s): " filename) | 240 | (read-file-name (format "Save as (default: %s): " filename) |
| @@ -209,7 +259,8 @@ nil for the other types." | |||
| 209 | ;; DATA is a MIME-entity object. | 259 | ;; DATA is a MIME-entity object. |
| 210 | (let ((transfer-encoding (rmail-mime-entity-transfer-encoding data)) | 260 | (let ((transfer-encoding (rmail-mime-entity-transfer-encoding data)) |
| 211 | (body (rmail-mime-entity-body data))) | 261 | (body (rmail-mime-entity-body data))) |
| 212 | (insert-buffer-substring mbox-buf (car body) (cdr body)) | 262 | (insert-buffer-substring rmail-mime-mbox-buffer |
| 263 | (aref body 0) (aref body 1)) | ||
| 213 | (cond ((string= transfer-encoding "base64") | 264 | (cond ((string= transfer-encoding "base64") |
| 214 | (ignore-errors (base64-decode-region (point-min) (point-max)))) | 265 | (ignore-errors (base64-decode-region (point-min) (point-max)))) |
| 215 | ((string= transfer-encoding "quoted-printable") | 266 | ((string= transfer-encoding "quoted-printable") |
| @@ -218,34 +269,293 @@ nil for the other types." | |||
| 218 | 269 | ||
| 219 | (define-button-type 'rmail-mime-save 'action 'rmail-mime-save) | 270 | (define-button-type 'rmail-mime-save 'action 'rmail-mime-save) |
| 220 | 271 | ||
| 272 | (defun rmail-mime-entity-segment (pos &optional entity) | ||
| 273 | "Return a vector describing the displayed region of a MIME-entity at POS. | ||
| 274 | Optional 2nd argument ENTITY is the MIME-entity at POS. | ||
| 275 | The value is a vector [ INDEX HEADER TAGLINE BODY END], where | ||
| 276 | HEADER: the position of the beginning of a header | ||
| 277 | TAGLINE: the position of the beginning of a tagline | ||
| 278 | BODY: the position of the beginning of a body | ||
| 279 | END: the position of the end of the entity. | ||
| 280 | INDEX: index into the returned vector indicating where POS is." | ||
| 281 | (save-excursion | ||
| 282 | (or entity | ||
| 283 | (setq entity (get-text-property pos 'rmail-mime-entity))) | ||
| 284 | (if (not entity) | ||
| 285 | (vector 1 (point) (point) (point) (point)) | ||
| 286 | (let ((current (aref (rmail-mime-entity-display entity) 0)) | ||
| 287 | (beg (if (and (> pos (point-min)) | ||
| 288 | (eq (get-text-property (1- pos) 'rmail-mime-entity) | ||
| 289 | entity)) | ||
| 290 | (previous-single-property-change pos 'rmail-mime-entity | ||
| 291 | nil (point-min)) | ||
| 292 | pos)) | ||
| 293 | (index 1) | ||
| 294 | tagline-beg body-beg end) | ||
| 295 | (goto-char beg) | ||
| 296 | (if (aref current 0) | ||
| 297 | (search-forward "\n\n" nil t)) | ||
| 298 | (setq tagline-beg (point)) | ||
| 299 | (if (>= pos tagline-beg) | ||
| 300 | (setq index 2)) | ||
| 301 | (if (aref current 1) | ||
| 302 | (forward-line 1)) | ||
| 303 | (setq body-beg (point)) | ||
| 304 | (if (>= pos body-beg) | ||
| 305 | (setq index 3)) | ||
| 306 | (if (aref current 2) | ||
| 307 | (let ((tag (aref (rmail-mime-entity-tagline entity) 0)) | ||
| 308 | tag2) | ||
| 309 | (setq end (next-single-property-change beg 'rmail-mime-entity | ||
| 310 | nil (point-max))) | ||
| 311 | (while (and (< end (point-max)) | ||
| 312 | (setq entity (get-text-property end 'rmail-mime-entity) | ||
| 313 | tag2 (aref (rmail-mime-entity-tagline entity) 0)) | ||
| 314 | (and (> (length tag2) 0) | ||
| 315 | (eq (string-match tag tag2) 0))) | ||
| 316 | (setq end (next-single-property-change end 'rmail-mime-entity | ||
| 317 | nil (point-max))))) | ||
| 318 | (setq end body-beg)) | ||
| 319 | (vector index beg tagline-beg body-beg end))))) | ||
| 320 | |||
| 321 | (defun rmail-mime-next-item () | ||
| 322 | "Move point to the next displayed item of the current MIME entity. | ||
| 323 | A MIME entity has three items; header, tagline, and body. | ||
| 324 | If we are in the last item of the entity, move point to the first | ||
| 325 | item of the next entity. If we reach the end of buffer, move | ||
| 326 | point to the first item of the first entity (i.e. the beginning | ||
| 327 | of buffer)." | ||
| 328 | (interactive) | ||
| 329 | (if (rmail-mime-message-p) | ||
| 330 | (let* ((segment (rmail-mime-entity-segment (point))) | ||
| 331 | (next-pos (aref segment (1+ (aref segment 0)))) | ||
| 332 | (button (next-button (point)))) | ||
| 333 | (goto-char (if (and button (< (button-start button) next-pos)) | ||
| 334 | (button-start button) | ||
| 335 | next-pos)) | ||
| 336 | (if (eobp) | ||
| 337 | (goto-char (point-min)))))) | ||
| 338 | |||
| 339 | (defun rmail-mime-previous-item () | ||
| 340 | "Move point to the previous displayed item of the current MIME message. | ||
| 341 | A MIME entity has three items; header, tagline, and body. | ||
| 342 | If we are at the beginning of the first item of the entity, move | ||
| 343 | point to the last item of the previous entity. If we reach the | ||
| 344 | beginning of buffer, move point to the last item of the last | ||
| 345 | entity." | ||
| 346 | (interactive) | ||
| 347 | (when (rmail-mime-message-p) | ||
| 348 | (if (bobp) | ||
| 349 | (goto-char (point-max))) | ||
| 350 | (let* ((segment (rmail-mime-entity-segment (1- (point)))) | ||
| 351 | (prev-pos (aref segment (aref segment 0))) | ||
| 352 | (button (previous-button (point)))) | ||
| 353 | (goto-char (if (and button (> (button-start button) prev-pos)) | ||
| 354 | (button-start button) | ||
| 355 | prev-pos))))) | ||
| 356 | |||
| 357 | (defun rmail-mime-shown-mode (entity) | ||
| 358 | "Make MIME-entity ENTITY displayed by the default way." | ||
| 359 | (let ((new (aref (rmail-mime-entity-display entity) 1))) | ||
| 360 | (aset new 0 (aref (rmail-mime-entity-header entity) 2)) | ||
| 361 | (aset new 1 (aref (rmail-mime-entity-tagline entity) 2)) | ||
| 362 | (aset new 2 (aref (rmail-mime-entity-body entity) 2)))) | ||
| 363 | |||
| 364 | (defun rmail-mime-hidden-mode (entity top) | ||
| 365 | "Make MIME-entity ENTITY displayed in the hidden mode. | ||
| 366 | If TOP is non-nil, display ENTITY only by the tagline. | ||
| 367 | Otherwise, don't display ENTITY." | ||
| 368 | (if top | ||
| 369 | (let ((new (aref (rmail-mime-entity-display entity) 1))) | ||
| 370 | (aset new 0 nil) | ||
| 371 | (aset new 1 top) | ||
| 372 | (aset new 2 nil) | ||
| 373 | (aset (rmail-mime-entity-body entity) 2 nil)) | ||
| 374 | (let ((current (aref (rmail-mime-entity-display entity) 0))) | ||
| 375 | (aset current 0 nil) | ||
| 376 | (aset current 1 nil) | ||
| 377 | (aset current 2 nil))) | ||
| 378 | (dolist (child (rmail-mime-entity-children entity)) | ||
| 379 | (rmail-mime-hidden-mode child nil))) | ||
| 380 | |||
| 381 | (defun rmail-mime-raw-mode (entity) | ||
| 382 | "Make MIME-entity ENTITY displayed in the raw mode." | ||
| 383 | (let ((new (aref (rmail-mime-entity-display entity) 1))) | ||
| 384 | (aset new 0 'raw) | ||
| 385 | (aset new 1 nil) | ||
| 386 | (aset new 2 'raw) | ||
| 387 | (dolist (child (rmail-mime-entity-children entity)) | ||
| 388 | (rmail-mime-hidden-mode child nil)))) | ||
| 389 | |||
| 390 | (defun rmail-mime-toggle-raw (entity) | ||
| 391 | "Toggle on and off the raw display mode of MIME-entity ENTITY." | ||
| 392 | (let* ((pos (if (eobp) (1- (point-max)) (point))) | ||
| 393 | (entity (get-text-property pos 'rmail-mime-entity)) | ||
| 394 | (current (aref (rmail-mime-entity-display entity) 0)) | ||
| 395 | (segment (rmail-mime-entity-segment pos entity))) | ||
| 396 | (if (not (eq (aref current 0) 'raw)) | ||
| 397 | ;; Enter the raw mode. | ||
| 398 | (rmail-mime-raw-mode entity) | ||
| 399 | ;; Enter the shown mode. | ||
| 400 | (rmail-mime-shown-mode entity)) | ||
| 401 | (let ((inhibit-read-only t) | ||
| 402 | (modified (buffer-modified-p))) | ||
| 403 | (save-excursion | ||
| 404 | (goto-char (aref segment 1)) | ||
| 405 | (rmail-mime-insert entity) | ||
| 406 | (restore-buffer-modified-p modified))))) | ||
| 407 | |||
| 408 | (defun rmail-mime-toggle-hidden () | ||
| 409 | "Toggle on and off the hidden display mode of MIME-entity ENTITY." | ||
| 410 | (interactive) | ||
| 411 | (when (rmail-mime-message-p) | ||
| 412 | (let* ((rmail-mime-mbox-buffer rmail-view-buffer) | ||
| 413 | (rmail-mime-view-buffer (current-buffer)) | ||
| 414 | (pos (if (eobp) (1- (point-max)) (point))) | ||
| 415 | (entity (get-text-property pos 'rmail-mime-entity)) | ||
| 416 | (current (aref (rmail-mime-entity-display entity) 0)) | ||
| 417 | (segment (rmail-mime-entity-segment pos entity))) | ||
| 418 | (if (aref current 2) | ||
| 419 | ;; Enter the hidden mode. | ||
| 420 | (progn | ||
| 421 | ;; If point is in the body part, move it to the tagline | ||
| 422 | ;; (or the header if headline is not displayed). | ||
| 423 | (if (= (aref segment 0) 3) | ||
| 424 | (goto-char (aref segment 2))) | ||
| 425 | (rmail-mime-hidden-mode entity t) | ||
| 426 | ;; If the current entity is the topmost one, display the | ||
| 427 | ;; header. | ||
| 428 | (if (and rmail-mime-mbox-buffer (= (aref segment 1) (point-min))) | ||
| 429 | (let ((new (aref (rmail-mime-entity-display entity) 1))) | ||
| 430 | (aset new 0 t)))) | ||
| 431 | ;; Enter the shown mode. | ||
| 432 | (aset (rmail-mime-entity-body entity) 2 t) | ||
| 433 | (rmail-mime-shown-mode entity)) | ||
| 434 | (let ((inhibit-read-only t) | ||
| 435 | (modified (buffer-modified-p)) | ||
| 436 | (rmail-mime-mbox-buffer rmail-view-buffer) | ||
| 437 | (rmail-mime-view-buffer rmail-buffer)) | ||
| 438 | (save-excursion | ||
| 439 | (goto-char (aref segment 1)) | ||
| 440 | (rmail-mime-insert entity) | ||
| 441 | (restore-buffer-modified-p modified)))))) | ||
| 442 | |||
| 443 | (define-key rmail-mode-map "\t" 'rmail-mime-next-item) | ||
| 444 | (define-key rmail-mode-map [backtab] 'rmail-mime-previous-item) | ||
| 445 | (define-key rmail-mode-map "\r" 'rmail-mime-toggle-hidden) | ||
| 446 | |||
| 221 | ;;; Handlers | 447 | ;;; Handlers |
| 222 | 448 | ||
| 449 | (defun rmail-mime-insert-tagline (entity &rest item-list) | ||
| 450 | "Insert a tag line for MIME-entity ENTITY. | ||
| 451 | ITEM-LIST is a list of strings or button-elements (list) to be added | ||
| 452 | to the tag line." | ||
| 453 | (insert "[") | ||
| 454 | (let ((tag (aref (rmail-mime-entity-tagline entity) 0))) | ||
| 455 | (if (> (length tag) 0) (insert (substring tag 1) ":"))) | ||
| 456 | (insert (car (rmail-mime-entity-type entity))) | ||
| 457 | (dolist (item item-list) | ||
| 458 | (when item | ||
| 459 | (if (stringp item) | ||
| 460 | (insert item) | ||
| 461 | (apply 'insert-button item)))) | ||
| 462 | (insert "]\n")) | ||
| 463 | |||
| 464 | (defun rmail-mime-insert-header (header) | ||
| 465 | "Decode and insert a MIME-entity header HEADER in the current buffer. | ||
| 466 | HEADER is a vector [BEG END DEFAULT-STATUS]. | ||
| 467 | See `rmail-mime-entity' for the detail." | ||
| 468 | (let ((pos (point)) | ||
| 469 | (last-coding-system-used nil)) | ||
| 470 | (save-restriction | ||
| 471 | (narrow-to-region pos pos) | ||
| 472 | (with-current-buffer rmail-mime-mbox-buffer | ||
| 473 | (let ((rmail-buffer rmail-mime-mbox-buffer) | ||
| 474 | (rmail-view-buffer rmail-mime-view-buffer)) | ||
| 475 | (save-excursion | ||
| 476 | (goto-char (aref header 0)) | ||
| 477 | (rmail-copy-headers (point) (aref header 1))))) | ||
| 478 | (rfc2047-decode-region pos (point)) | ||
| 479 | (if (and last-coding-system-used (not rmail-mime-coding-system)) | ||
| 480 | (setq rmail-mime-coding-system last-coding-system-used)) | ||
| 481 | (goto-char (point-min)) | ||
| 482 | (rmail-highlight-headers) | ||
| 483 | (goto-char (point-max)) | ||
| 484 | (insert "\n")))) | ||
| 485 | |||
| 223 | (defun rmail-mime-text-handler (content-type | 486 | (defun rmail-mime-text-handler (content-type |
| 224 | content-disposition | 487 | content-disposition |
| 225 | content-transfer-encoding) | 488 | content-transfer-encoding) |
| 226 | "Handle the current buffer as a plain text MIME part." | 489 | "Handle the current buffer as a plain text MIME part." |
| 227 | (let* ((charset (cdr (assq 'charset (cdr content-type)))) | 490 | (rmail-mime-insert-text |
| 228 | (coding-system (when charset | 491 | (rmail-mime-entity content-type content-disposition |
| 229 | (intern (downcase charset))))) | 492 | content-transfer-encoding |
| 230 | (when (coding-system-p coding-system) | 493 | (vector (vector nil nil nil) (vector nil nil t)) |
| 231 | (decode-coding-region (point-min) (point-max) coding-system)))) | 494 | (vector nil nil nil) (vector "" (cons nil nil) t) |
| 232 | 495 | (vector nil nil nil) nil 'rmail-mime-insert-text)) | |
| 233 | (defun rmail-mime-insert-text (entity) | 496 | t) |
| 234 | "Insert MIME-entity ENTITY as a plain text MIME part in the current buffer." | 497 | |
| 498 | (defun rmail-mime-insert-decoded-text (entity) | ||
| 499 | "Decode and insert the text body of MIME-entity ENTITY." | ||
| 235 | (let* ((content-type (rmail-mime-entity-type entity)) | 500 | (let* ((content-type (rmail-mime-entity-type entity)) |
| 236 | (charset (cdr (assq 'charset (cdr content-type)))) | 501 | (charset (cdr (assq 'charset (cdr content-type)))) |
| 237 | (coding-system (if charset (intern (downcase charset)))) | 502 | (coding-system (if charset |
| 238 | (transfer-encoding (rmail-mime-entity-transfer-encoding entity)) | 503 | (coding-system-from-name charset))) |
| 239 | (body (rmail-mime-entity-body entity))) | 504 | (body (rmail-mime-entity-body entity)) |
| 240 | (save-restriction | 505 | (pos (point))) |
| 241 | (narrow-to-region (point) (point)) | 506 | (or (and coding-system (coding-system-p coding-system)) |
| 242 | (insert-buffer-substring rmail-buffer (car body) (cdr body)) | 507 | (setq coding-system 'undecided)) |
| 243 | (cond ((string= transfer-encoding "base64") | 508 | (if (stringp (aref body 0)) |
| 244 | (ignore-errors (base64-decode-region (point-min) (point-max)))) | 509 | (insert (aref body 0)) |
| 245 | ((string= transfer-encoding "quoted-printable") | 510 | (let ((transfer-encoding (rmail-mime-entity-transfer-encoding entity))) |
| 246 | (quoted-printable-decode-region (point-min) (point-max)))) | 511 | (insert-buffer-substring rmail-mime-mbox-buffer |
| 247 | (if (coding-system-p coding-system) | 512 | (aref body 0) (aref body 1)) |
| 248 | (decode-coding-region (point-min) (point-max) coding-system))))) | 513 | (cond ((string= transfer-encoding "base64") |
| 514 | (ignore-errors (base64-decode-region pos (point)))) | ||
| 515 | ((string= transfer-encoding "quoted-printable") | ||
| 516 | (quoted-printable-decode-region pos (point)))))) | ||
| 517 | (decode-coding-region pos (point) coding-system) | ||
| 518 | (or rmail-mime-coding-system | ||
| 519 | (setq rmail-mime-coding-system coding-system)) | ||
| 520 | (or (bolp) (insert "\n")))) | ||
| 521 | |||
| 522 | (defun rmail-mime-insert-text (entity) | ||
| 523 | "Presentation handler for a plain text MIME entity." | ||
| 524 | (let ((current (aref (rmail-mime-entity-display entity) 0)) | ||
| 525 | (new (aref (rmail-mime-entity-display entity) 1)) | ||
| 526 | (header (rmail-mime-entity-header entity)) | ||
| 527 | (tagline (rmail-mime-entity-tagline entity)) | ||
| 528 | (body (rmail-mime-entity-body entity)) | ||
| 529 | (beg (point)) | ||
| 530 | (segment (rmail-mime-entity-segment (point) entity))) | ||
| 531 | |||
| 532 | (or (integerp (aref body 0)) | ||
| 533 | (let ((data (buffer-string))) | ||
| 534 | (aset body 0 data) | ||
| 535 | (delete-region (point-min) (point-max)))) | ||
| 536 | |||
| 537 | ;; header | ||
| 538 | (if (eq (aref current 0) (aref new 0)) | ||
| 539 | (goto-char (aref segment 2)) | ||
| 540 | (if (aref current 0) | ||
| 541 | (delete-char (- (aref segment 2) (aref segment 1)))) | ||
| 542 | (if (aref new 0) | ||
| 543 | (rmail-mime-insert-header header))) | ||
| 544 | ;; tagline | ||
| 545 | (if (eq (aref current 1) (aref new 1)) | ||
| 546 | (forward-char (- (aref segment 3) (aref segment 2))) | ||
| 547 | (if (aref current 1) | ||
| 548 | (delete-char (- (aref segment 3) (aref segment 2)))) | ||
| 549 | (if (aref new 1) | ||
| 550 | (rmail-mime-insert-tagline entity))) | ||
| 551 | ;; body | ||
| 552 | (if (eq (aref current 2) (aref new 2)) | ||
| 553 | (forward-char (- (aref segment 4) (aref segment 3))) | ||
| 554 | (if (aref current 2) | ||
| 555 | (delete-char (- (aref segment 4) (aref segment 3)))) | ||
| 556 | (if (aref new 2) | ||
| 557 | (rmail-mime-insert-decoded-text entity))) | ||
| 558 | (put-text-property beg (point) 'rmail-mime-entity entity))) | ||
| 249 | 559 | ||
| 250 | ;; FIXME move to the test/ directory? | 560 | ;; FIXME move to the test/ directory? |
| 251 | (defun test-rmail-mime-handler () | 561 | (defun test-rmail-mime-handler () |
| @@ -264,35 +574,35 @@ MIME-Version: 1.0 | |||
| 264 | (set-buffer-multibyte t))) | 574 | (set-buffer-multibyte t))) |
| 265 | 575 | ||
| 266 | 576 | ||
| 267 | (defun rmail-mime-insert-image (type data) | 577 | (defun rmail-mime-insert-image (entity) |
| 268 | "Insert an image of type TYPE, where DATA is the image data. | 578 | "Decode and insert the image body of MIME-entity ENTITY." |
| 269 | If DATA is not a string, it is a MIME-entity object." | 579 | (let* ((content-type (car (rmail-mime-entity-type entity))) |
| 270 | (end-of-line) | 580 | (bulk-data (aref (rmail-mime-entity-tagline entity) 1)) |
| 271 | (let ((modified (buffer-modified-p))) | 581 | (body (rmail-mime-entity-body entity)) |
| 272 | (insert ?\n) | 582 | data) |
| 273 | (unless (stringp data) | 583 | (if (stringp (aref body 0)) |
| 274 | ;; DATA is a MIME-entity. | 584 | (setq data (aref body 0)) |
| 275 | (let ((transfer-encoding (rmail-mime-entity-transfer-encoding data)) | 585 | (let ((rmail-mime-mbox-buffer rmail-view-buffer) |
| 276 | (body (rmail-mime-entity-body data)) | 586 | (transfer-encoding (rmail-mime-entity-transfer-encoding entity))) |
| 277 | (mbox-buffer rmail-view-buffer)) | ||
| 278 | (with-temp-buffer | 587 | (with-temp-buffer |
| 279 | (set-buffer-multibyte nil) | 588 | (set-buffer-multibyte nil) |
| 280 | (setq buffer-undo-list t) | 589 | (setq buffer-undo-list t) |
| 281 | (insert-buffer-substring mbox-buffer (car body) (cdr body)) | 590 | (insert-buffer-substring rmail-mime-mbox-buffer |
| 591 | (aref body 0) (aref body 1)) | ||
| 282 | (cond ((string= transfer-encoding "base64") | 592 | (cond ((string= transfer-encoding "base64") |
| 283 | (ignore-errors (base64-decode-region (point-min) (point-max)))) | 593 | (ignore-errors (base64-decode-region (point-min) (point-max)))) |
| 284 | ((string= transfer-encoding "quoted-printable") | 594 | ((string= transfer-encoding "quoted-printable") |
| 285 | (quoted-printable-decode-region (point-min) (point-max)))) | 595 | (quoted-printable-decode-region (point-min) (point-max)))) |
| 286 | (setq data | 596 | (setq data |
| 287 | (buffer-substring-no-properties (point-min) (point-max)))))) | 597 | (buffer-substring-no-properties (point-min) (point-max)))))) |
| 288 | (insert-image (create-image data type t)) | 598 | (insert-image (create-image data (cdr bulk-data) t)) |
| 289 | (set-buffer-modified-p modified))) | 599 | (insert "\n"))) |
| 290 | 600 | ||
| 291 | (defun rmail-mime-image (button) | 601 | (defun rmail-mime-image (button) |
| 292 | "Display the image associated with BUTTON." | 602 | "Display the image associated with BUTTON." |
| 293 | (let ((inhibit-read-only t)) | 603 | (save-excursion |
| 294 | (rmail-mime-insert-image (button-get button 'image-type) | 604 | (goto-char (button-end button)) |
| 295 | (button-get button 'image-data)))) | 605 | (rmail-mime-toggle-hidden))) |
| 296 | 606 | ||
| 297 | (define-button-type 'rmail-mime-image 'action 'rmail-mime-image) | 607 | (define-button-type 'rmail-mime-image 'action 'rmail-mime-image) |
| 298 | 608 | ||
| @@ -305,15 +615,60 @@ For images that Emacs is capable of displaying, the behavior | |||
| 305 | depends upon the value of `rmail-mime-show-images'." | 615 | depends upon the value of `rmail-mime-show-images'." |
| 306 | (rmail-mime-insert-bulk | 616 | (rmail-mime-insert-bulk |
| 307 | (rmail-mime-entity content-type content-disposition content-transfer-encoding | 617 | (rmail-mime-entity content-type content-disposition content-transfer-encoding |
| 308 | nil nil nil))) | 618 | (vector (vector nil nil nil) (vector nil t nil)) |
| 619 | (vector nil nil nil) (vector "" (cons nil nil) t) | ||
| 620 | (vector nil nil nil) nil 'rmail-mime-insert-bulk))) | ||
| 621 | |||
| 622 | (defun rmail-mime-set-bulk-data (entity) | ||
| 623 | "Setup the information about the attachment object for MIME-entity ENTITY. | ||
| 624 | The value is non-nil if and only if the attachment object should be shown | ||
| 625 | directly." | ||
| 626 | (let ((content-type (car (rmail-mime-entity-type entity))) | ||
| 627 | (size (cdr (assq 'size (cdr (rmail-mime-entity-disposition entity))))) | ||
| 628 | (bulk-data (aref (rmail-mime-entity-tagline entity) 1)) | ||
| 629 | (body (rmail-mime-entity-body entity)) | ||
| 630 | size type to-show) | ||
| 631 | (cond (size | ||
| 632 | (setq size (string-to-number size))) | ||
| 633 | ((stringp (aref body 0)) | ||
| 634 | (setq size (length (aref body 0)))) | ||
| 635 | (t | ||
| 636 | ;; Rough estimation of the size. | ||
| 637 | (let ((encoding (rmail-mime-entity-transfer-encoding entity))) | ||
| 638 | (setq size (- (aref body 1) (aref body 0))) | ||
| 639 | (cond ((string= encoding "base64") | ||
| 640 | (setq size (/ (* size 3) 4))) | ||
| 641 | ((string= encoding "quoted-printable") | ||
| 642 | (setq size (/ (* size 7) 3))))))) | ||
| 643 | |||
| 644 | (cond | ||
| 645 | ((string-match "text/" content-type) | ||
| 646 | (setq type 'text)) | ||
| 647 | ((string-match "image/\\(.*\\)" content-type) | ||
| 648 | (setq type (image-type-from-file-name | ||
| 649 | (concat "." (match-string 1 content-type)))) | ||
| 650 | (if (and (memq type image-types) | ||
| 651 | (image-type-available-p type)) | ||
| 652 | (if (and rmail-mime-show-images | ||
| 653 | (not (eq rmail-mime-show-images 'button)) | ||
| 654 | (or (not (numberp rmail-mime-show-images)) | ||
| 655 | (< size rmail-mime-show-images))) | ||
| 656 | (setq to-show t)) | ||
| 657 | (setq type nil)))) | ||
| 658 | (setcar bulk-data size) | ||
| 659 | (setcdr bulk-data type) | ||
| 660 | to-show)) | ||
| 309 | 661 | ||
| 310 | (defun rmail-mime-insert-bulk (entity) | 662 | (defun rmail-mime-insert-bulk (entity) |
| 311 | "Inesrt a MIME-entity ENTITY as an attachment. | 663 | "Presentation handler for an attachment MIME entity." |
| 312 | The optional second arg DATA, if non-nil, is a string containing | ||
| 313 | the attachment data that is already decoded." | ||
| 314 | ;; Find the default directory for this media type. | 664 | ;; Find the default directory for this media type. |
| 315 | (let* ((content-type (rmail-mime-entity-type entity)) | 665 | (let* ((content-type (rmail-mime-entity-type entity)) |
| 316 | (content-disposition (rmail-mime-entity-disposition entity)) | 666 | (content-disposition (rmail-mime-entity-disposition entity)) |
| 667 | (current (aref (rmail-mime-entity-display entity) 0)) | ||
| 668 | (new (aref (rmail-mime-entity-display entity) 1)) | ||
| 669 | (header (rmail-mime-entity-header entity)) | ||
| 670 | (tagline (rmail-mime-entity-tagline entity)) | ||
| 671 | (bulk-data (aref tagline 1)) | ||
| 317 | (body (rmail-mime-entity-body entity)) | 672 | (body (rmail-mime-entity-body entity)) |
| 318 | (directory (catch 'directory | 673 | (directory (catch 'directory |
| 319 | (dolist (entry rmail-mime-attachment-dirs-alist) | 674 | (dolist (entry rmail-mime-attachment-dirs-alist) |
| @@ -324,47 +679,70 @@ the attachment data that is already decoded." | |||
| 324 | (filename (or (cdr (assq 'name (cdr content-type))) | 679 | (filename (or (cdr (assq 'name (cdr content-type))) |
| 325 | (cdr (assq 'filename (cdr content-disposition))) | 680 | (cdr (assq 'filename (cdr content-disposition))) |
| 326 | "noname")) | 681 | "noname")) |
| 327 | (label (format "\nAttached %s file: " (car content-type))) | ||
| 328 | (units '(B kB MB GB)) | 682 | (units '(B kB MB GB)) |
| 329 | data udata size osize type) | 683 | (segment (rmail-mime-entity-segment (point) entity)) |
| 330 | (if body | 684 | beg data size) |
| 685 | |||
| 686 | (if (integerp (aref body 0)) | ||
| 331 | (setq data entity | 687 | (setq data entity |
| 332 | udata entity | 688 | size (car bulk-data)) |
| 333 | size (- (cdr body) (car body))) | 689 | (if (stringp (aref body 0)) |
| 334 | (setq data (buffer-string) | 690 | (setq data (aref body 0)) |
| 335 | udata (string-as-unibyte data) | 691 | (setq data (string-as-unibyte (buffer-string))) |
| 336 | size (length udata)) | 692 | (aset body 0 data) |
| 337 | (delete-region (point-min) (point-max))) | 693 | (rmail-mime-set-bulk-data entity) |
| 338 | (setq osize size) | 694 | (delete-region (point-min) (point-max))) |
| 695 | (setq size (length data))) | ||
| 339 | (while (and (> size 1024.0) ; cribbed from gnus-agent-expire-done-message | 696 | (while (and (> size 1024.0) ; cribbed from gnus-agent-expire-done-message |
| 340 | (cdr units)) | 697 | (cdr units)) |
| 341 | (setq size (/ size 1024.0) | 698 | (setq size (/ size 1024.0) |
| 342 | units (cdr units))) | 699 | units (cdr units))) |
| 343 | (insert label) | 700 | |
| 344 | (insert-button filename | 701 | (setq beg (point)) |
| 345 | :type 'rmail-mime-save | 702 | |
| 346 | 'help-echo "mouse-2, RET: Save attachment" | 703 | ;; header |
| 347 | 'filename filename | 704 | (if (eq (aref current 0) (aref new 0)) |
| 348 | 'directory (file-name-as-directory directory) | 705 | (goto-char (aref segment 2)) |
| 349 | 'data data) | 706 | (if (aref current 0) |
| 350 | (insert (format " (%.0f%s)" size (car units))) | 707 | (delete-char (- (aref segment 2) (aref segment 1)))) |
| 351 | (when (and rmail-mime-show-images | 708 | (if (aref new 0) |
| 352 | (string-match "image/\\(.*\\)" (setq type (car content-type))) | 709 | (rmail-mime-insert-header header))) |
| 353 | (setq type (concat "." (match-string 1 type)) | 710 | |
| 354 | type (image-type-from-file-name type)) | 711 | ;; tagline |
| 355 | (memq type image-types) | 712 | (if (eq (aref current 1) (aref new 1)) |
| 356 | (image-type-available-p type)) | 713 | (forward-char (- (aref segment 3) (aref segment 2))) |
| 357 | (insert " ") | 714 | (if (aref current 1) |
| 358 | (cond ((or (eq rmail-mime-show-images 'button) | 715 | (delete-char (- (aref segment 3) (aref segment 2)))) |
| 359 | (and (numberp rmail-mime-show-images) | 716 | (if (aref new 1) |
| 360 | (>= osize rmail-mime-show-images))) | 717 | (rmail-mime-insert-tagline |
| 361 | (insert-button "Display" | 718 | entity |
| 362 | :type 'rmail-mime-image | 719 | " file:" |
| 363 | 'help-echo "mouse-2, RET: Show image" | 720 | (list filename |
| 364 | 'image-type type | 721 | :type 'rmail-mime-save |
| 365 | 'image-data udata)) | 722 | 'help-echo "mouse-2, RET: Save attachment" |
| 366 | (t | 723 | 'filename filename |
| 367 | (rmail-mime-insert-image type udata)))))) | 724 | 'directory (file-name-as-directory directory) |
| 725 | 'data data) | ||
| 726 | (format " (%.0f%s)" size (car units)) | ||
| 727 | (if (cdr bulk-data) | ||
| 728 | " ") | ||
| 729 | (if (cdr bulk-data) | ||
| 730 | (list "Toggle show/hide" | ||
| 731 | :type 'rmail-mime-image | ||
| 732 | 'help-echo "mouse-2, RET: Toggle show/hide" | ||
| 733 | 'image-type (cdr bulk-data) | ||
| 734 | 'image-data data))))) | ||
| 735 | ;; body | ||
| 736 | (if (eq (aref current 2) (aref new 2)) | ||
| 737 | (forward-char (- (aref segment 4) (aref segment 3))) | ||
| 738 | (if (aref current 2) | ||
| 739 | (delete-char (- (aref segment 4) (aref segment 3)))) | ||
| 740 | (if (aref new 2) | ||
| 741 | (cond ((eq (cdr bulk-data) 'text) | ||
| 742 | (rmail-mime-insert-decoded-text entity)) | ||
| 743 | ((cdr bulk-data) | ||
| 744 | (rmail-mime-insert-image entity))))) | ||
| 745 | (put-text-property beg (point) 'rmail-mime-entity entity))) | ||
| 368 | 746 | ||
| 369 | (defun test-rmail-mime-bulk-handler () | 747 | (defun test-rmail-mime-bulk-handler () |
| 370 | "Test of a mail used as an example in RFC 2183." | 748 | "Test of a mail used as an example in RFC 2183." |
| @@ -396,19 +774,21 @@ CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values | |||
| 396 | of the respective parsed headers. See `rmail-mime-handle' for their | 774 | of the respective parsed headers. See `rmail-mime-handle' for their |
| 397 | format." | 775 | format." |
| 398 | (rmail-mime-process-multipart | 776 | (rmail-mime-process-multipart |
| 399 | content-type content-disposition content-transfer-encoding nil)) | 777 | content-type content-disposition content-transfer-encoding nil) |
| 778 | t) | ||
| 400 | 779 | ||
| 401 | (defun rmail-mime-process-multipart (content-type | 780 | (defun rmail-mime-process-multipart (content-type |
| 402 | content-disposition | 781 | content-disposition |
| 403 | content-transfer-encoding | 782 | content-transfer-encoding |
| 404 | parse-only) | 783 | parse-tag) |
| 405 | "Process the current buffer as a multipart MIME body. | 784 | "Process the current buffer as a multipart MIME body. |
| 406 | 785 | ||
| 407 | If PARSE-ONLY is nil, modify the current buffer directly for showing | 786 | If PARSE-TAG is nil, modify the current buffer directly for |
| 408 | the MIME body and return nil. | 787 | showing the MIME body and return nil. |
| 409 | 788 | ||
| 410 | Otherwise, just parse the current buffer and return a list of | 789 | Otherwise, PARSE-TAG is a string indicating the depth and index |
| 411 | MIME-entity objects. | 790 | number of the entity. In this case, parse the current buffer and |
| 791 | return a list of MIME-entity objects. | ||
| 412 | 792 | ||
| 413 | The other arguments are the same as `rmail-mime-multipart-handler'." | 793 | The other arguments are the same as `rmail-mime-multipart-handler'." |
| 414 | ;; Some MUAs start boundaries with "--", while it should start | 794 | ;; Some MUAs start boundaries with "--", while it should start |
| @@ -419,6 +799,8 @@ The other arguments are the same as `rmail-mime-multipart-handler'." | |||
| 419 | ;; of the preceding part. | 799 | ;; of the preceding part. |
| 420 | ;; We currently don't handle that. | 800 | ;; We currently don't handle that. |
| 421 | (let ((boundary (cdr (assq 'boundary content-type))) | 801 | (let ((boundary (cdr (assq 'boundary content-type))) |
| 802 | (subtype (cadr (split-string (car content-type) "/"))) | ||
| 803 | (index 0) | ||
| 422 | beg end next entities) | 804 | beg end next entities) |
| 423 | (unless boundary | 805 | (unless boundary |
| 424 | (rmail-mm-get-boundary-error-message | 806 | (rmail-mm-get-boundary-error-message |
| @@ -429,12 +811,20 @@ The other arguments are the same as `rmail-mime-multipart-handler'." | |||
| 429 | (goto-char (point-min)) | 811 | (goto-char (point-min)) |
| 430 | (when (and (search-forward boundary nil t) | 812 | (when (and (search-forward boundary nil t) |
| 431 | (looking-at "[ \t]*\n")) | 813 | (looking-at "[ \t]*\n")) |
| 432 | (if parse-only | 814 | (if parse-tag |
| 433 | (narrow-to-region (match-end 0) (point-max)) | 815 | (narrow-to-region (match-end 0) (point-max)) |
| 434 | (delete-region (point-min) (match-end 0)))) | 816 | (delete-region (point-min) (match-end 0)))) |
| 817 | |||
| 818 | ;; Change content-type to the proper default one for the children. | ||
| 819 | (cond ((string-match "mixed" subtype) | ||
| 820 | (setq content-type '("text/plain"))) | ||
| 821 | ((string-match "digest" subtype) | ||
| 822 | (setq content-type '("message/rfc822")))) | ||
| 823 | |||
| 435 | ;; Loop over all body parts, where beg points at the beginning of | 824 | ;; Loop over all body parts, where beg points at the beginning of |
| 436 | ;; the part and end points at the end of the part. next points at | 825 | ;; the part and end points at the end of the part. next points at |
| 437 | ;; the beginning of the next part. | 826 | ;; the beginning of the next part. The current point is just |
| 827 | ;; after the boundary tag. | ||
| 438 | (setq beg (point-min)) | 828 | (setq beg (point-min)) |
| 439 | (while (search-forward boundary nil t) | 829 | (while (search-forward boundary nil t) |
| 440 | (setq end (match-beginning 0)) | 830 | (setq end (match-beginning 0)) |
| @@ -449,17 +839,46 @@ The other arguments are the same as `rmail-mime-multipart-handler'." | |||
| 449 | (rmail-mm-get-boundary-error-message | 839 | (rmail-mm-get-boundary-error-message |
| 450 | "Malformed boundary" content-type content-disposition | 840 | "Malformed boundary" content-type content-disposition |
| 451 | content-transfer-encoding))) | 841 | content-transfer-encoding))) |
| 842 | |||
| 843 | (setq index (1+ index)) | ||
| 452 | ;; Handle the part. | 844 | ;; Handle the part. |
| 453 | (if parse-only | 845 | (if parse-tag |
| 454 | (save-restriction | 846 | (save-restriction |
| 455 | (narrow-to-region beg end) | 847 | (narrow-to-region beg end) |
| 456 | (setq entities (cons (rmail-mime-process nil t) entities))) | 848 | (let ((child (rmail-mime-process |
| 849 | nil (format "%s/%d" parse-tag index) | ||
| 850 | content-type content-disposition))) | ||
| 851 | ;; Display a tagline. | ||
| 852 | (aset (aref (rmail-mime-entity-display child) 1) 1 | ||
| 853 | (aset (rmail-mime-entity-tagline child) 2 t)) | ||
| 854 | (push child entities))) | ||
| 855 | |||
| 457 | (delete-region end next) | 856 | (delete-region end next) |
| 458 | (save-restriction | 857 | (save-restriction |
| 459 | (narrow-to-region beg end) | 858 | (narrow-to-region beg end) |
| 460 | (rmail-mime-show))) | 859 | (rmail-mime-show))) |
| 461 | (goto-char (setq beg next))) | 860 | (goto-char (setq beg next))) |
| 462 | (nreverse entities))) | 861 | |
| 862 | (when parse-tag | ||
| 863 | (setq entities (nreverse entities)) | ||
| 864 | (if (string-match "alternative" subtype) | ||
| 865 | ;; Find the best entity to show, and hide all the others. | ||
| 866 | (let (best second) | ||
| 867 | (dolist (child entities) | ||
| 868 | (if (string= (or (car (rmail-mime-entity-disposition child)) | ||
| 869 | (car content-disposition)) | ||
| 870 | "inline") | ||
| 871 | (if (string-match "text/plain" | ||
| 872 | (car (rmail-mime-entity-type child))) | ||
| 873 | (setq best child) | ||
| 874 | (if (string-match "text/.*" | ||
| 875 | (car (rmail-mime-entity-type child))) | ||
| 876 | (setq second child))))) | ||
| 877 | (or best (not second) (setq best second)) | ||
| 878 | (dolist (child entities) | ||
| 879 | (or (eq best child) | ||
| 880 | (rmail-mime-hidden-mode child t))))) | ||
| 881 | entities))) | ||
| 463 | 882 | ||
| 464 | (defun test-rmail-mime-multipart-handler () | 883 | (defun test-rmail-mime-multipart-handler () |
| 465 | "Test of a mail used as an example in RFC 2046." | 884 | "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.")) | |||
| 492 | (insert mail) | 911 | (insert mail) |
| 493 | (rmail-mime-show t))) | 912 | (rmail-mime-show t))) |
| 494 | 913 | ||
| 914 | (defun rmail-mime-insert-multipart (entity) | ||
| 915 | "Presentation handler for a multipart MIME entity." | ||
| 916 | (let ((current (aref (rmail-mime-entity-display entity) 0)) | ||
| 917 | (new (aref (rmail-mime-entity-display entity) 1)) | ||
| 918 | (header (rmail-mime-entity-header entity)) | ||
| 919 | (tagline (rmail-mime-entity-tagline entity)) | ||
| 920 | (body (rmail-mime-entity-body entity)) | ||
| 921 | (beg (point)) | ||
| 922 | (segment (rmail-mime-entity-segment (point) entity))) | ||
| 923 | ;; header | ||
| 924 | (if (eq (aref current 0) (aref new 0)) | ||
| 925 | (goto-char (aref segment 2)) | ||
| 926 | (if (aref current 0) | ||
| 927 | (delete-char (- (aref segment 2) (aref segment 1)))) | ||
| 928 | (if (aref new 0) | ||
| 929 | (rmail-mime-insert-header header))) | ||
| 930 | ;; tagline | ||
| 931 | (if (eq (aref current 1) (aref new 1)) | ||
| 932 | (forward-char (- (aref segment 3) (aref segment 2))) | ||
| 933 | (if (aref current 1) | ||
| 934 | (delete-char (- (aref segment 3) (aref segment 2)))) | ||
| 935 | (if (aref new 1) | ||
| 936 | (rmail-mime-insert-tagline entity))) | ||
| 937 | |||
| 938 | (put-text-property beg (point) 'rmail-mime-entity entity) | ||
| 939 | ;; body | ||
| 940 | (if (eq (aref current 2) (aref new 2)) | ||
| 941 | (forward-char (- (aref segment 4) (aref segment 3))) | ||
| 942 | (if (aref current 2) | ||
| 943 | (delete-char (- (aref segment 4) (aref segment 3)))) | ||
| 944 | (if (aref new 2) | ||
| 945 | (dolist (child (rmail-mime-entity-children entity)) | ||
| 946 | (rmail-mime-insert child)))))) | ||
| 947 | |||
| 495 | ;;; Main code | 948 | ;;; Main code |
| 496 | 949 | ||
| 497 | (defun rmail-mime-handle (content-type | 950 | (defun rmail-mime-handle (content-type |
| @@ -564,7 +1017,9 @@ The current buffer must contain a single message. It will be | |||
| 564 | modified." | 1017 | modified." |
| 565 | (rmail-mime-process show-headers nil)) | 1018 | (rmail-mime-process show-headers nil)) |
| 566 | 1019 | ||
| 567 | (defun rmail-mime-process (show-headers parse-only) | 1020 | (defun rmail-mime-process (show-headers parse-tag &optional |
| 1021 | default-content-type | ||
| 1022 | default-content-disposition) | ||
| 568 | (let ((end (point-min)) | 1023 | (let ((end (point-min)) |
| 569 | content-type | 1024 | content-type |
| 570 | content-transfer-encoding | 1025 | content-transfer-encoding |
| @@ -595,45 +1050,76 @@ modified." | |||
| 595 | (setq content-type | 1050 | (setq content-type |
| 596 | (if content-type | 1051 | (if content-type |
| 597 | (mail-header-parse-content-type content-type) | 1052 | (mail-header-parse-content-type content-type) |
| 598 | ;; FIXME: Default "message/rfc822" in a "multipart/digest" | 1053 | (or default-content-type '("text/plain")))) |
| 599 | ;; according to RFC 2046. | ||
| 600 | '("text/plain"))) | ||
| 601 | (setq content-disposition | 1054 | (setq content-disposition |
| 602 | (if content-disposition | 1055 | (if content-disposition |
| 603 | (mail-header-parse-content-disposition content-disposition) | 1056 | (mail-header-parse-content-disposition content-disposition) |
| 604 | ;; If none specified, we are free to choose what we deem | 1057 | ;; If none specified, we are free to choose what we deem |
| 605 | ;; suitable according to RFC 2183. We like inline. | 1058 | ;; suitable according to RFC 2183. We like inline. |
| 606 | '("inline"))) | 1059 | (or default-content-disposition '("inline")))) |
| 607 | ;; Unrecognized disposition types are to be treated like | 1060 | ;; Unrecognized disposition types are to be treated like |
| 608 | ;; attachment according to RFC 2183. | 1061 | ;; attachment according to RFC 2183. |
| 609 | (unless (member (car content-disposition) '("inline" "attachment")) | 1062 | (unless (member (car content-disposition) '("inline" "attachment")) |
| 610 | (setq content-disposition '("attachment"))) | 1063 | (setq content-disposition '("attachment"))) |
| 611 | 1064 | ||
| 612 | (if parse-only | 1065 | (if parse-tag |
| 613 | (cond ((string-match "multipart/.*" (car content-type)) | 1066 | (let* ((is-inline (string= (car content-disposition) "inline")) |
| 614 | (setq end (1- end)) | 1067 | (header (vector (point-min) end nil)) |
| 615 | (save-restriction | 1068 | (tagline (vector parse-tag (cons nil nil) t)) |
| 616 | (let ((header (if show-headers (cons (point-min) end)))) | 1069 | (body (vector end (point-max) is-inline)) |
| 1070 | (new (vector (aref header 2) (aref tagline 2) (aref body 2))) | ||
| 1071 | children handler entity) | ||
| 1072 | (cond ((string-match "multipart/.*" (car content-type)) | ||
| 1073 | (save-restriction | ||
| 1074 | (narrow-to-region (1- end) (point-max)) | ||
| 1075 | (setq children (rmail-mime-process-multipart | ||
| 1076 | content-type | ||
| 1077 | content-disposition | ||
| 1078 | content-transfer-encoding | ||
| 1079 | parse-tag) | ||
| 1080 | handler 'rmail-mime-insert-multipart))) | ||
| 1081 | ((string-match "message/rfc822" (car content-type)) | ||
| 1082 | (save-restriction | ||
| 617 | (narrow-to-region end (point-max)) | 1083 | (narrow-to-region end (point-max)) |
| 618 | (rmail-mime-entity content-type | 1084 | (let* ((msg (rmail-mime-process t parse-tag |
| 619 | content-disposition | 1085 | '("text/plain") '("inline"))) |
| 620 | content-transfer-encoding | 1086 | (msg-new (aref (rmail-mime-entity-display msg) 1))) |
| 621 | header nil | 1087 | ;; Show header of the child. |
| 622 | (rmail-mime-process-multipart | 1088 | (aset msg-new 0 t) |
| 623 | content-type content-disposition | 1089 | (aset (rmail-mime-entity-header msg) 2 t) |
| 624 | content-transfer-encoding t))))) | 1090 | ;; Hide tagline of the child. |
| 625 | ((string-match "message/rfc822" (car content-type)) | 1091 | (aset msg-new 1 nil) |
| 626 | (or show-headers | 1092 | (aset (rmail-mime-entity-tagline msg) 2 nil) |
| 627 | (narrow-to-region end (point-max))) | 1093 | (setq children (list msg) |
| 628 | (rmail-mime-process t t)) | 1094 | handler 'rmail-mime-insert-multipart)))) |
| 629 | (t | 1095 | ((and is-inline (string-match "text/" (car content-type))) |
| 630 | (rmail-mime-entity content-type | 1096 | ;; Don't need a tagline. |
| 631 | content-disposition | 1097 | (aset new 1 (aset tagline 2 nil)) |
| 632 | content-transfer-encoding | 1098 | (setq handler 'rmail-mime-insert-text)) |
| 633 | nil | 1099 | (t |
| 634 | (cons end (point-max)) | 1100 | ;; Force hidden mode. |
| 635 | nil))) | 1101 | (aset new 1 (aset tagline 2 t)) |
| 1102 | (aset new 2 (aset body 2 nil)) | ||
| 1103 | (setq handler 'rmail-mime-insert-bulk))) | ||
| 1104 | (setq entity (rmail-mime-entity content-type | ||
| 1105 | content-disposition | ||
| 1106 | content-transfer-encoding | ||
| 1107 | (vector (vector nil nil nil) new) | ||
| 1108 | header tagline body children handler)) | ||
| 1109 | (if (and (eq handler 'rmail-mime-insert-bulk) | ||
| 1110 | (rmail-mime-set-bulk-data entity)) | ||
| 1111 | ;; Show the body. | ||
| 1112 | (aset new 2 (aset body 2 t))) | ||
| 1113 | entity) | ||
| 1114 | |||
| 636 | ;; Hide headers and handle the part. | 1115 | ;; Hide headers and handle the part. |
| 1116 | (put-text-property (point-min) (point-max) 'rmail-mime-entity | ||
| 1117 | (rmail-mime-entity | ||
| 1118 | content-type content-disposition | ||
| 1119 | content-transfer-encoding | ||
| 1120 | (vector (vector 'raw nil 'raw) (vector 'raw nil 'raw)) | ||
| 1121 | (vector nil nil 'raw) (vector "" (cons nil nil) nil) | ||
| 1122 | (vector nil nil 'raw) nil nil)) | ||
| 637 | (save-restriction | 1123 | (save-restriction |
| 638 | (cond ((string= (car content-type) "message/rfc822") | 1124 | (cond ((string= (car content-type) "message/rfc822") |
| 639 | (narrow-to-region end (point-max))) | 1125 | (narrow-to-region end (point-max))) |
| @@ -642,102 +1128,117 @@ modified." | |||
| 642 | (rmail-mime-handle content-type content-disposition | 1128 | (rmail-mime-handle content-type content-disposition |
| 643 | content-transfer-encoding))))) | 1129 | content-transfer-encoding))))) |
| 644 | 1130 | ||
| 645 | (defun rmail-mime-insert-multipart (entity) | ||
| 646 | "Insert MIME-entity ENTITY of multipart type in the current buffer." | ||
| 647 | (let ((subtype (cadr (split-string (car (rmail-mime-entity-type entity)) | ||
| 648 | "/"))) | ||
| 649 | (disposition (rmail-mime-entity-disposition entity)) | ||
| 650 | (header (rmail-mime-entity-header entity)) | ||
| 651 | (children (rmail-mime-entity-children entity))) | ||
| 652 | (if header | ||
| 653 | (let ((pos (point))) | ||
| 654 | (or (bolp) | ||
| 655 | (insert "\n")) | ||
| 656 | (insert-buffer-substring rmail-buffer (car header) (cdr header)) | ||
| 657 | (rfc2047-decode-region pos (point)) | ||
| 658 | (insert "\n"))) | ||
| 659 | (cond | ||
| 660 | ((string= subtype "mixed") | ||
| 661 | (dolist (child children) | ||
| 662 | (rmail-mime-insert child '("text/plain") disposition))) | ||
| 663 | ((string= subtype "digest") | ||
| 664 | (dolist (child children) | ||
| 665 | (rmail-mime-insert child '("message/rfc822") disposition))) | ||
| 666 | ((string= subtype "alternative") | ||
| 667 | (let (best-plain-text best-text) | ||
| 668 | (dolist (child children) | ||
| 669 | (if (string= (or (car (rmail-mime-entity-disposition child)) | ||
| 670 | (car disposition)) | ||
| 671 | "inline") | ||
| 672 | (if (string-match "text/plain" | ||
| 673 | (car (rmail-mime-entity-type child))) | ||
| 674 | (setq best-plain-text child) | ||
| 675 | (if (string-match "text/.*" | ||
| 676 | (car (rmail-mime-entity-type child))) | ||
| 677 | (setq best-text child))))) | ||
| 678 | (if (or best-plain-text best-text) | ||
| 679 | (rmail-mime-insert (or best-plain-text best-text)) | ||
| 680 | ;; No child could be handled. Insert all. | ||
| 681 | (dolist (child children) | ||
| 682 | (rmail-mime-insert child nil disposition))))) | ||
| 683 | (t | ||
| 684 | ;; Unsupported subtype. Insert all of them. | ||
| 685 | (dolist (child children) | ||
| 686 | (rmail-mime-insert child)))))) | ||
| 687 | |||
| 688 | (defun rmail-mime-parse () | 1131 | (defun rmail-mime-parse () |
| 689 | "Parse the current Rmail message as a MIME message. | 1132 | "Parse the current Rmail message as a MIME message. |
| 690 | The value is a MIME-entiy object (see `rmail-mime-enty-new')." | 1133 | The value is a MIME-entiy object (see `rmail-mime-entity')." |
| 691 | (save-excursion | 1134 | (let ((rmail-mime-mbox-buffer (if (rmail-buffers-swapped-p) |
| 692 | (goto-char (point-min)) | 1135 | rmail-view-buffer |
| 693 | (condition-case nil | 1136 | (current-buffer)))) |
| 694 | (rmail-mime-process nil t) | 1137 | ;;(condition-case err |
| 695 | (error nil)))) | 1138 | (with-current-buffer rmail-mime-mbox-buffer |
| 696 | 1139 | (save-excursion | |
| 697 | (defun rmail-mime-insert (entity &optional content-type disposition) | 1140 | (goto-char (point-min)) |
| 1141 | (let* ((entity (rmail-mime-process t "" | ||
| 1142 | '("text/plain") '("inline"))) | ||
| 1143 | (new (aref (rmail-mime-entity-display entity) 1))) | ||
| 1144 | ;; Show header. | ||
| 1145 | (aset new 0 (aset (rmail-mime-entity-header entity) 2 t)) | ||
| 1146 | ;; Show tagline if and only if body is not shown. | ||
| 1147 | (if (aref new 2) | ||
| 1148 | (aset new 1 (aset (rmail-mime-entity-tagline entity) 2 nil)) | ||
| 1149 | (aset new 1 (aset (rmail-mime-entity-tagline entity) 2 t))) | ||
| 1150 | entity))) | ||
| 1151 | ;;(error (error (format "%s" err)))) | ||
| 1152 | )) | ||
| 1153 | |||
| 1154 | (defun rmail-mime-insert (entity) | ||
| 698 | "Insert a MIME-entity ENTITY in the current buffer. | 1155 | "Insert a MIME-entity ENTITY in the current buffer. |
| 699 | 1156 | ||
| 700 | This function will be called recursively if multiple parts are | 1157 | This function will be called recursively if multiple parts are |
| 701 | available." | 1158 | available." |
| 702 | (if (rmail-mime-entity-children entity) | 1159 | (let ((current (aref (rmail-mime-entity-display entity) 0)) |
| 703 | (rmail-mime-insert-multipart entity) | 1160 | (new (aref (rmail-mime-entity-display entity) 1))) |
| 704 | (setq content-type | 1161 | (if (not (eq (aref new 0) 'raw)) |
| 705 | (or (rmail-mime-entity-type entity) content-type)) | 1162 | ;; Not a raw-mode. Each handler should handle it. |
| 706 | (setq disposition | 1163 | (funcall (rmail-mime-entity-handler entity) entity) |
| 707 | (or (rmail-mime-entity-disposition entity) disposition)) | 1164 | (let ((header (rmail-mime-entity-header entity)) |
| 708 | (if (and (string= (car disposition) "inline") | 1165 | (tagline (rmail-mime-entity-tagline entity)) |
| 709 | (string-match "text/.*" (car content-type))) | 1166 | (body (rmail-mime-entity-body entity)) |
| 710 | (rmail-mime-insert-text entity) | 1167 | (beg (point)) |
| 711 | (rmail-mime-insert-bulk entity)))) | 1168 | (segment (rmail-mime-entity-segment (point) entity))) |
| 1169 | ;; header | ||
| 1170 | (if (eq (aref current 0) (aref new 0)) | ||
| 1171 | (goto-char (aref segment 2)) | ||
| 1172 | (if (aref current 0) | ||
| 1173 | (delete-char (- (aref segment 2) (aref segment 1)))) | ||
| 1174 | (insert-buffer-substring rmail-mime-mbox-buffer | ||
| 1175 | (aref header 0) (aref header 1))) | ||
| 1176 | ;; tagline | ||
| 1177 | (if (aref current 1) | ||
| 1178 | (delete-char (- (aref segment 3) (aref segment 2)))) | ||
| 1179 | ;; body | ||
| 1180 | (if (eq (aref current 2) (aref new 2)) | ||
| 1181 | (forward-char (- (aref segment 4) (aref segment 3))) | ||
| 1182 | (if (aref current 2) | ||
| 1183 | (delete-char (- (aref segment 4) (aref segment 3)))) | ||
| 1184 | (insert-buffer-substring rmail-mime-mbox-buffer | ||
| 1185 | (aref body 0) (aref body 1))) | ||
| 1186 | (put-text-property beg (point) 'rmail-mime-entity entity))) | ||
| 1187 | (dotimes (i 3) | ||
| 1188 | (aset current i (aref new i))))) | ||
| 712 | 1189 | ||
| 713 | (define-derived-mode rmail-mime-mode fundamental-mode "RMIME" | 1190 | (define-derived-mode rmail-mime-mode fundamental-mode "RMIME" |
| 714 | "Major mode used in `rmail-mime' buffers." | 1191 | "Major mode used in `rmail-mime' buffers." |
| 715 | (setq font-lock-defaults '(rmail-font-lock-keywords t t nil nil))) | 1192 | (setq font-lock-defaults '(rmail-font-lock-keywords t t nil nil))) |
| 716 | 1193 | ||
| 717 | ;;;###autoload | 1194 | ;;;###autoload |
| 718 | (defun rmail-mime () | 1195 | (defun rmail-mime (&optional arg) |
| 719 | "Process the current Rmail message as a MIME message. | 1196 | "Toggle displaying of a MIME message. |
| 720 | This creates a temporary \"*RMAIL*\" buffer holding a decoded | 1197 | |
| 721 | copy of the message. Inline content-types are handled according to | 1198 | The actualy behavior depends on the value of `rmail-enable-mime'. |
| 1199 | |||
| 1200 | If `rmail-enable-mime' is t (default), this command change the | ||
| 1201 | displaying of a MIME message between decoded presentation form | ||
| 1202 | and raw data. | ||
| 1203 | |||
| 1204 | With ARG, toggle the displaying of the current MIME entity only. | ||
| 1205 | |||
| 1206 | If `rmail-enable-mime' is nil, this creates a temporary | ||
| 1207 | \"*RMAIL*\" buffer holding a decoded copy of the message. Inline | ||
| 1208 | content-types are handled according to | ||
| 722 | `rmail-mime-media-type-handlers-alist'. By default, this | 1209 | `rmail-mime-media-type-handlers-alist'. By default, this |
| 723 | displays text and multipart messages, and offers to download | 1210 | displays text and multipart messages, and offers to download |
| 724 | attachments as specfied by `rmail-mime-attachment-dirs-alist'." | 1211 | attachments as specfied by `rmail-mime-attachment-dirs-alist'." |
| 725 | (interactive) | 1212 | (interactive "P") |
| 726 | (let ((data (rmail-apply-in-message rmail-current-message 'buffer-string)) | 1213 | (if rmail-enable-mime |
| 727 | (buf (get-buffer-create "*RMAIL*"))) | 1214 | (if (rmail-mime-message-p) |
| 728 | (set-buffer buf) | 1215 | (let ((rmail-mime-mbox-buffer rmail-view-buffer) |
| 729 | (setq buffer-undo-list t) | 1216 | (rmail-mime-view-buffer rmail-buffer) |
| 730 | (let ((inhibit-read-only t)) | 1217 | (entity (get-text-property (point) 'rmail-mime-entity))) |
| 731 | ;; Decoding the message in fundamental mode for speed, only | 1218 | (if arg |
| 732 | ;; switching to rmail-mime-mode at the end for display. Eg | 1219 | (if entity |
| 733 | ;; quoted-printable-decode-region gets very slow otherwise (Bug#4993). | 1220 | (rmail-mime-toggle-raw entity)) |
| 734 | (fundamental-mode) | 1221 | (goto-char (point-min)) |
| 735 | (erase-buffer) | 1222 | (rmail-mime-toggle-raw |
| 736 | (insert data) | 1223 | (get-text-property (point) 'rmail-mime-entity)))) |
| 737 | (rmail-mime-show t) | 1224 | (message "Not a MIME message")) |
| 738 | (rmail-mime-mode) | 1225 | (let* ((data (rmail-apply-in-message rmail-current-message 'buffer-string)) |
| 739 | (set-buffer-modified-p nil)) | 1226 | (buf (get-buffer-create "*RMAIL*")) |
| 740 | (view-buffer buf))) | 1227 | (rmail-mime-mbox-buffer rmail-view-buffer) |
| 1228 | (rmail-mime-view-buffer buf)) | ||
| 1229 | (set-buffer buf) | ||
| 1230 | (setq buffer-undo-list t) | ||
| 1231 | (let ((inhibit-read-only t)) | ||
| 1232 | ;; Decoding the message in fundamental mode for speed, only | ||
| 1233 | ;; switching to rmail-mime-mode at the end for display. Eg | ||
| 1234 | ;; quoted-printable-decode-region gets very slow otherwise (Bug#4993). | ||
| 1235 | (fundamental-mode) | ||
| 1236 | (erase-buffer) | ||
| 1237 | (insert data) | ||
| 1238 | (rmail-mime-show t) | ||
| 1239 | (rmail-mime-mode) | ||
| 1240 | (set-buffer-modified-p nil)) | ||
| 1241 | (view-buffer buf)))) | ||
| 741 | 1242 | ||
| 742 | (defun rmail-mm-get-boundary-error-message (message type disposition encoding) | 1243 | (defun rmail-mm-get-boundary-error-message (message type disposition encoding) |
| 743 | "Return MESSAGE with more information on the main mime components." | 1244 | "Return MESSAGE with more information on the main mime components." |
| @@ -746,34 +1247,39 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'." | |||
| 746 | 1247 | ||
| 747 | (defun rmail-show-mime () | 1248 | (defun rmail-show-mime () |
| 748 | "Function to set in `rmail-show-mime-function' (which see)." | 1249 | "Function to set in `rmail-show-mime-function' (which see)." |
| 749 | (let ((mbox-buf rmail-buffer) | 1250 | (let ((entity (rmail-mime-parse)) |
| 750 | (entity (rmail-mime-parse))) | 1251 | (rmail-mime-mbox-buffer rmail-buffer) |
| 1252 | (rmail-mime-view-buffer rmail-view-buffer) | ||
| 1253 | (rmail-mime-coding-system nil)) | ||
| 751 | (if entity | 1254 | (if entity |
| 752 | (with-current-buffer rmail-view-buffer | 1255 | (with-current-buffer rmail-mime-view-buffer |
| 753 | (let ((inhibit-read-only t) | 1256 | (erase-buffer) |
| 754 | (rmail-buffer mbox-buf)) | 1257 | (rmail-mime-insert entity) |
| 755 | (erase-buffer) | 1258 | (if rmail-mime-coding-system |
| 756 | (rmail-mime-insert entity))) | 1259 | (set-buffer-file-coding-system rmail-mime-coding-system t t))) |
| 757 | ;; Decoding failed. Insert the original message body as is. | 1260 | ;; Decoding failed. Insert the original message body as is. |
| 758 | (let ((region (with-current-buffer mbox-buf | 1261 | (let ((region (with-current-buffer rmail-mime-mbox-buffer |
| 759 | (goto-char (point-min)) | 1262 | (goto-char (point-min)) |
| 760 | (re-search-forward "^$" nil t) | 1263 | (re-search-forward "^$" nil t) |
| 761 | (forward-line 1) | 1264 | (forward-line 1) |
| 762 | (cons (point) (point-max))))) | 1265 | (cons (point) (point-max))))) |
| 763 | (with-current-buffer rmail-view-buffer | 1266 | (with-current-buffer rmail-mime-view-buffer |
| 764 | (let ((inhibit-read-only t)) | 1267 | (let ((inhibit-read-only t)) |
| 765 | (erase-buffer) | 1268 | (erase-buffer) |
| 766 | (insert-buffer-substring mbox-buf (car region) (cdr region)))) | 1269 | (insert-buffer-substring rmail-mime-mbox-buffer |
| 1270 | (car region) (cdr region)))) | ||
| 1271 | (set-buffer-file-coding-system 'no-conversion t t) | ||
| 767 | (message "MIME decoding failed"))))) | 1272 | (message "MIME decoding failed"))))) |
| 768 | 1273 | ||
| 769 | (setq rmail-show-mime-function 'rmail-show-mime) | 1274 | (setq rmail-show-mime-function 'rmail-show-mime) |
| 770 | 1275 | ||
| 771 | (defun rmail-insert-mime-forwarded-message (forward-buffer) | 1276 | (defun rmail-insert-mime-forwarded-message (forward-buffer) |
| 772 | "Function to set in `rmail-insert-mime-forwarded-message-function' (which see)." | 1277 | "Function to set in `rmail-insert-mime-forwarded-message-function' (which see)." |
| 773 | (let ((mbox-buf (with-current-buffer forward-buffer rmail-view-buffer))) | 1278 | (let ((rmail-mime-mbox-buffer |
| 1279 | (with-current-buffer forward-buffer rmail-view-buffer))) | ||
| 774 | (save-restriction | 1280 | (save-restriction |
| 775 | (narrow-to-region (point) (point)) | 1281 | (narrow-to-region (point) (point)) |
| 776 | (message-forward-make-body-mime mbox-buf)))) | 1282 | (message-forward-make-body-mime rmail-mime-mbox-buffer)))) |
| 777 | 1283 | ||
| 778 | (setq rmail-insert-mime-forwarded-message-function | 1284 | (setq rmail-insert-mime-forwarded-message-function |
| 779 | 'rmail-insert-mime-forwarded-message) | 1285 | 'rmail-insert-mime-forwarded-message) |
| @@ -794,15 +1300,16 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'." | |||
| 794 | "Function to set in `rmail-search-mime-message-function' (which see)." | 1300 | "Function to set in `rmail-search-mime-message-function' (which see)." |
| 795 | (save-restriction | 1301 | (save-restriction |
| 796 | (narrow-to-region (rmail-msgbeg msg) (rmail-msgend msg)) | 1302 | (narrow-to-region (rmail-msgbeg msg) (rmail-msgend msg)) |
| 797 | (let ((mbox-buf (current-buffer)) | 1303 | (let* ((rmail-mime-mbox-buffer (current-buffer)) |
| 798 | (header-end (save-excursion | 1304 | (rmail-mime-view-buffer rmail-view-buffer) |
| 799 | (re-search-forward "^$" nil 'move) (point))) | 1305 | (header-end (save-excursion |
| 800 | (body-end (point-max)) | 1306 | (re-search-forward "^$" nil 'move) (point))) |
| 801 | (entity (rmail-mime-parse))) | 1307 | (body-end (point-max)) |
| 1308 | (entity (rmail-mime-parse))) | ||
| 802 | (or | 1309 | (or |
| 803 | ;; At first, just search the headers. | 1310 | ;; At first, just search the headers. |
| 804 | (with-temp-buffer | 1311 | (with-temp-buffer |
| 805 | (insert-buffer-substring mbox-buf nil header-end) | 1312 | (insert-buffer-substring rmail-mime-mbox-buffer nil header-end) |
| 806 | (rfc2047-decode-region (point-min) (point)) | 1313 | (rfc2047-decode-region (point-min) (point)) |
| 807 | (goto-char (point-min)) | 1314 | (goto-char (point-min)) |
| 808 | (re-search-forward regexp nil t)) | 1315 | (re-search-forward regexp nil t)) |
| @@ -815,8 +1322,7 @@ attachments as specfied by `rmail-mime-attachment-dirs-alist'." | |||
| 815 | (not (string= (downcase charset) "us-ascii")))))) | 1322 | (not (string= (downcase charset) "us-ascii")))))) |
| 816 | ;; Search the decoded MIME message. | 1323 | ;; Search the decoded MIME message. |
| 817 | (with-temp-buffer | 1324 | (with-temp-buffer |
| 818 | (let ((rmail-buffer mbox-buf)) | 1325 | (rmail-mime-insert entity) |
| 819 | (rmail-mime-insert entity)) | ||
| 820 | (goto-char (point-min)) | 1326 | (goto-char (point-min)) |
| 821 | (re-search-forward regexp nil t)) | 1327 | (re-search-forward regexp nil t)) |
| 822 | ;; Search the body without decoding. | 1328 | ;; Search the body without decoding. |