| 1 | ;;; rmailmm.el --- MIME decoding and display stuff for RMAIL |
| 2 | |
| 3 | ;; Copyright (C) 2006-2012 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Alexander Pohoyda |
| 6 | ;; Alex Schroeder |
| 7 | ;; Maintainer: FSF |
| 8 | ;; Keywords: mail |
| 9 | ;; Package: rmail |
| 10 | |
| 11 | ;; This file is part of GNU Emacs. |
| 12 | |
| 13 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 14 | ;; it under the terms of the GNU General Public License as published by |
| 15 | ;; the Free Software Foundation, either version 3 of the License, or |
| 16 | ;; (at your option) any later version. |
| 17 | |
| 18 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 21 | ;; GNU General Public License for more details. |
| 22 | |
| 23 | ;; You should have received a copy of the GNU General Public License |
| 24 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 25 | |
| 26 | ;;; Commentary: |
| 27 | |
| 28 | ;; Essentially based on the design of Alexander Pohoyda's MIME |
| 29 | ;; extensions (mime-display.el and mime.el). |
| 30 | |
| 31 | ;; This file provides two operation modes for viewing a MIME message. |
| 32 | |
| 33 | ;; (1) When rmail-enable-mime is non-nil (now it is the default), the |
| 34 | ;; function `rmail-show-mime' is automatically called. That function |
| 35 | ;; shows a MIME message directly in RMAIL's view buffer. |
| 36 | |
| 37 | ;; (2) When rmail-enable-mime is nil, the command 'v' (or M-x |
| 38 | ;; rmail-mime) shows a MIME message in a new buffer "*RMAIL*". |
| 39 | |
| 40 | ;; Both operations share the intermediate functions rmail-mime-process |
| 41 | ;; and rmail-mime-process-multipart as below. |
| 42 | |
| 43 | ;; rmail-show-mime |
| 44 | ;; +- rmail-mime-parse |
| 45 | ;; | +- rmail-mime-process <--+------------+ |
| 46 | ;; | | +---------+ | |
| 47 | ;; | + rmail-mime-process-multipart --+ |
| 48 | ;; | |
| 49 | ;; + rmail-mime-insert <----------------+ |
| 50 | ;; +- rmail-mime-insert-text | |
| 51 | ;; +- rmail-mime-insert-bulk | |
| 52 | ;; +- rmail-mime-insert-multipart --+ |
| 53 | ;; |
| 54 | ;; rmail-mime |
| 55 | ;; +- rmail-mime-show <----------------------------------+ |
| 56 | ;; +- rmail-mime-process | |
| 57 | ;; +- rmail-mime-handle | |
| 58 | ;; +- rmail-mime-text-handler | |
| 59 | ;; +- rmail-mime-bulk-handler | |
| 60 | ;; | + rmail-mime-insert-bulk |
| 61 | ;; +- rmail-mime-multipart-handler | |
| 62 | ;; +- rmail-mime-process-multipart --+ |
| 63 | |
| 64 | ;; In addition, for the case of rmail-enable-mime being non-nil, this |
| 65 | ;; file provides two functions rmail-insert-mime-forwarded-message and |
| 66 | ;; rmail-insert-mime-resent-message for composing forwarded and resent |
| 67 | ;; messages respectively. |
| 68 | |
| 69 | ;; Todo: |
| 70 | |
| 71 | ;; Make rmail-mime-media-type-handlers-alist usable in the first |
| 72 | ;; operation mode. |
| 73 | ;; Handle multipart/alternative in the second operation mode. |
| 74 | ;; Offer the option to call external/internal viewers (doc-view, xpdf, etc). |
| 75 | |
| 76 | ;;; Code: |
| 77 | |
| 78 | (require 'rmail) |
| 79 | (require 'mail-parse) |
| 80 | (require 'message) |
| 81 | |
| 82 | ;;; User options. |
| 83 | |
| 84 | (defgroup rmail-mime nil |
| 85 | "Rmail MIME handling options." |
| 86 | :prefix "rmail-mime-" |
| 87 | :group 'rmail) |
| 88 | |
| 89 | (defcustom rmail-mime-media-type-handlers-alist |
| 90 | '(("multipart/.*" rmail-mime-multipart-handler) |
| 91 | ("text/.*" rmail-mime-text-handler) |
| 92 | ("text/\\(x-\\)?patch" rmail-mime-bulk-handler) |
| 93 | ("\\(image\\|audio\\|video\\|application\\)/.*" rmail-mime-bulk-handler)) |
| 94 | "Functions to handle various content types. |
| 95 | This is an alist with elements of the form (REGEXP FUNCTION ...). |
| 96 | The first item is a regular expression matching a content-type. |
| 97 | The remaining elements are handler functions to run, in order of |
| 98 | decreasing preference. These are called until one returns non-nil. |
| 99 | Note that this only applies to items with an inline Content-Disposition, |
| 100 | all others are handled by `rmail-mime-bulk-handler'. |
| 101 | Note also that this alist is ignored when the variable |
| 102 | `rmail-enable-mime' is non-nil." |
| 103 | :type '(alist :key-type regexp :value-type (repeat function)) |
| 104 | :version "23.1" |
| 105 | :group 'rmail-mime) |
| 106 | |
| 107 | (defcustom rmail-mime-attachment-dirs-alist |
| 108 | `(("text/.*" "~/Documents") |
| 109 | ("image/.*" "~/Pictures") |
| 110 | (".*" "~/Desktop" "~" ,temporary-file-directory)) |
| 111 | "Default directories to save attachments of various types into. |
| 112 | This is an alist with elements of the form (REGEXP DIR ...). |
| 113 | The first item is a regular expression matching a content-type. |
| 114 | The remaining elements are directories, in order of decreasing preference. |
| 115 | The first directory that exists is used." |
| 116 | :type '(alist :key-type regexp :value-type (repeat directory)) |
| 117 | :version "23.1" |
| 118 | :group 'rmail-mime) |
| 119 | |
| 120 | (defcustom rmail-mime-show-images 'button |
| 121 | "What to do with image attachments that Emacs is capable of displaying. |
| 122 | If nil, do nothing special. If `button', add an extra button |
| 123 | that when pushed displays the image in the buffer. If a number, |
| 124 | automatically show images if they are smaller than that size (in |
| 125 | bytes), otherwise add a display button. Anything else means to |
| 126 | automatically display the image in the buffer." |
| 127 | :type '(choice (const :tag "Add button to view image" button) |
| 128 | (const :tag "No special treatment" nil) |
| 129 | (number :tag "Show if smaller than certain size") |
| 130 | (other :tag "Always show" show)) |
| 131 | :version "23.2" |
| 132 | :group 'rmail-mime) |
| 133 | |
| 134 | ;;; End of user options. |
| 135 | |
| 136 | ;;; Global variables that always have let-binding when referred. |
| 137 | |
| 138 | (defvar rmail-mime-mbox-buffer nil |
| 139 | "Buffer containing the mbox data. |
| 140 | The value is usually nil, and bound to a proper value while |
| 141 | processing MIME.") |
| 142 | |
| 143 | (defvar rmail-mime-view-buffer nil |
| 144 | "Buffer showing a message. |
| 145 | The value is usually nil, and bound to a proper value while |
| 146 | processing MIME.") |
| 147 | |
| 148 | (defvar rmail-mime-coding-system nil |
| 149 | "The first coding-system used for decoding a MIME entity. |
| 150 | The value is usually nil, and bound to non-nil while inserting |
| 151 | MIME entities.") |
| 152 | |
| 153 | ;;; MIME-entity object |
| 154 | |
| 155 | (defun rmail-mime-entity (type disposition transfer-encoding |
| 156 | display header tagline body children handler |
| 157 | &optional truncated) |
| 158 | "Return a newly created MIME-entity object from arguments. |
| 159 | |
| 160 | A MIME-entity is a vector of 10 elements: |
| 161 | |
| 162 | [TYPE DISPOSITION TRANSFER-ENCODING DISPLAY HEADER TAGLINE BODY |
| 163 | CHILDREN HANDLER TRUNCATED] |
| 164 | |
| 165 | TYPE and DISPOSITION correspond to MIME headers Content-Type and |
| 166 | Content-Disposition respectively, and have this format: |
| 167 | |
| 168 | \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...) |
| 169 | |
| 170 | Each VALUE is a string and each ATTRIBUTE is a string. |
| 171 | |
| 172 | Consider the following header, for example: |
| 173 | |
| 174 | Content-Type: multipart/mixed; |
| 175 | boundary=\"----=_NextPart_000_0104_01C617E4.BDEC4C40\" |
| 176 | |
| 177 | The corresponding TYPE argument must be: |
| 178 | |
| 179 | \(\"multipart/mixed\" |
| 180 | \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\")) |
| 181 | |
| 182 | TRANSFER-ENCODING corresponds to MIME header |
| 183 | Content-Transfer-Encoding, and is a lower-case string. |
| 184 | |
| 185 | DISPLAY is a vector [CURRENT NEW], where CURRENT indicates how |
| 186 | the header, tag line, and body of the entity are displayed now, |
| 187 | and NEW indicates how their display should be updated. |
| 188 | Both elements are vectors [HEADER-DISPLAY TAGLINE-DISPLAY BODY-DISPLAY], |
| 189 | where each constituent element is a symbol for the corresponding |
| 190 | item with these values: |
| 191 | nil: not displayed |
| 192 | t: displayed by the decoded presentation form |
| 193 | raw: displayed by the raw MIME data (for the header and body only) |
| 194 | |
| 195 | HEADER and BODY are vectors [BEG END DISPLAY-FLAG], where BEG and |
| 196 | END are markers that specify the region of the header or body lines |
| 197 | in RMAIL's data (mbox) buffer, and DISPLAY-FLAG non-nil means that the |
| 198 | header or body is, by default, displayed by the decoded |
| 199 | presentation form. |
| 200 | |
| 201 | TAGLINE is a vector [TAG BULK-DATA DISPLAY-FLAG], where TAG is a |
| 202 | string indicating the depth and index number of the entity, |
| 203 | BULK-DATA is a cons (SIZE . TYPE) indicating the size and type of |
| 204 | an attached data, DISPLAY-FLAG non-nil means that the tag line is |
| 205 | displayed by default. |
| 206 | |
| 207 | CHILDREN is a list of child MIME-entities. A \"multipart/*\" |
| 208 | entity has one or more children. A \"message/rfc822\" entity |
| 209 | has just one child. Any other entity has no child. |
| 210 | |
| 211 | HANDLER is a function to insert the entity according to DISPLAY. |
| 212 | It is called with one argument ENTITY. |
| 213 | |
| 214 | TRUNCATED is non-nil if the text of this entity was truncated." |
| 215 | |
| 216 | (vector type disposition transfer-encoding |
| 217 | display header tagline body children handler truncated)) |
| 218 | |
| 219 | ;; Accessors for a MIME-entity object. |
| 220 | (defsubst rmail-mime-entity-type (entity) (aref entity 0)) |
| 221 | (defsubst rmail-mime-entity-disposition (entity) (aref entity 1)) |
| 222 | (defsubst rmail-mime-entity-transfer-encoding (entity) (aref entity 2)) |
| 223 | (defsubst rmail-mime-entity-display (entity) (aref entity 3)) |
| 224 | (defsubst rmail-mime-entity-header (entity) (aref entity 4)) |
| 225 | (defsubst rmail-mime-entity-tagline (entity) (aref entity 5)) |
| 226 | (defsubst rmail-mime-entity-body (entity) (aref entity 6)) |
| 227 | (defsubst rmail-mime-entity-children (entity) (aref entity 7)) |
| 228 | (defsubst rmail-mime-entity-handler (entity) (aref entity 8)) |
| 229 | (defsubst rmail-mime-entity-truncated (entity) (aref entity 9)) |
| 230 | (defsubst rmail-mime-entity-set-truncated (entity truncated) |
| 231 | (aset entity 9 truncated)) |
| 232 | |
| 233 | (defsubst rmail-mime-message-p () |
| 234 | "Non-nil if and only if the current message is a MIME." |
| 235 | (or (get-text-property (point) 'rmail-mime-entity) |
| 236 | (get-text-property (point-min) 'rmail-mime-entity))) |
| 237 | |
| 238 | ;;; Buttons |
| 239 | |
| 240 | (defun rmail-mime-save (button) |
| 241 | "Save the attachment using info in the BUTTON." |
| 242 | (let* ((rmail-mime-mbox-buffer rmail-view-buffer) |
| 243 | (filename (button-get button 'filename)) |
| 244 | (directory (button-get button 'directory)) |
| 245 | (data (button-get button 'data)) |
| 246 | (ofilename filename)) |
| 247 | (if (and (not (stringp data)) |
| 248 | (rmail-mime-entity-truncated data)) |
| 249 | (unless (y-or-n-p "This entity is truncated; save anyway? ") |
| 250 | (error "Aborted"))) |
| 251 | (setq filename (expand-file-name |
| 252 | (read-file-name (format "Save as (default: %s): " filename) |
| 253 | directory |
| 254 | (expand-file-name filename directory)) |
| 255 | directory)) |
| 256 | ;; If arg is just a directory, use the default file name, but in |
| 257 | ;; that directory (copied from write-file). |
| 258 | (if (file-directory-p filename) |
| 259 | (setq filename (expand-file-name |
| 260 | (file-name-nondirectory ofilename) |
| 261 | (file-name-as-directory filename)))) |
| 262 | (with-temp-buffer |
| 263 | (set-buffer-file-coding-system 'no-conversion) |
| 264 | ;; Needed e.g. by jka-compr, so if the attachment is a compressed |
| 265 | ;; file, the magic signature compares equal with the unibyte |
| 266 | ;; signature string recorded in jka-compr-compression-info-list. |
| 267 | (set-buffer-multibyte nil) |
| 268 | (setq buffer-undo-list t) |
| 269 | (if (stringp data) |
| 270 | (insert data) |
| 271 | ;; DATA is a MIME-entity object. |
| 272 | (let ((transfer-encoding (rmail-mime-entity-transfer-encoding data)) |
| 273 | (body (rmail-mime-entity-body data))) |
| 274 | (insert-buffer-substring rmail-mime-mbox-buffer |
| 275 | (aref body 0) (aref body 1)) |
| 276 | (cond ((string= transfer-encoding "base64") |
| 277 | (ignore-errors (base64-decode-region (point-min) (point-max)))) |
| 278 | ((string= transfer-encoding "quoted-printable") |
| 279 | (quoted-printable-decode-region (point-min) (point-max)))))) |
| 280 | (write-region nil nil filename nil nil nil t)))) |
| 281 | |
| 282 | (define-button-type 'rmail-mime-save 'action 'rmail-mime-save) |
| 283 | |
| 284 | ;; Display options returned by rmail-mime-entity-display. |
| 285 | ;; Value is on of nil, t, raw. |
| 286 | (defsubst rmail-mime-display-header (disp) (aref disp 0)) |
| 287 | (defsubst rmail-mime-display-tagline (disp) (aref disp 1)) |
| 288 | (defsubst rmail-mime-display-body (disp) (aref disp 2)) |
| 289 | |
| 290 | (defun rmail-mime-entity-segment (pos &optional entity) |
| 291 | "Return a vector describing the displayed region of a MIME-entity at POS. |
| 292 | Optional 2nd argument ENTITY is the MIME-entity at POS. |
| 293 | The value is a vector [INDEX HEADER TAGLINE BODY END], where |
| 294 | INDEX: index into the returned vector indicating where POS is (1..3) |
| 295 | HEADER: the position of the beginning of a header |
| 296 | TAGLINE: the position of the beginning of a tag line, including |
| 297 | the newline that precedes it |
| 298 | BODY: the position of the beginning of a body |
| 299 | END: the position of the end of the entity." |
| 300 | (save-excursion |
| 301 | (or entity |
| 302 | (setq entity (get-text-property pos 'rmail-mime-entity))) |
| 303 | (if (not entity) |
| 304 | (vector 1 (point) (point) (point) (point)) |
| 305 | (let ((current (aref (rmail-mime-entity-display entity) 0)) |
| 306 | (beg (if (and (> pos (point-min)) |
| 307 | (eq (get-text-property (1- pos) 'rmail-mime-entity) |
| 308 | entity)) |
| 309 | (previous-single-property-change pos 'rmail-mime-entity |
| 310 | nil (point-min)) |
| 311 | pos)) |
| 312 | (index 1) |
| 313 | tagline-beg body-beg end) |
| 314 | (goto-char beg) |
| 315 | ;; If the header is displayed, get past it to the tagline. |
| 316 | (if (rmail-mime-display-header current) |
| 317 | (search-forward "\n\n" nil t)) |
| 318 | (setq tagline-beg (point)) |
| 319 | (if (>= pos tagline-beg) |
| 320 | (setq index 2)) |
| 321 | ;; If the tagline is displayed, get past it to the body. |
| 322 | (if (rmail-mime-display-tagline current) |
| 323 | ;; The next forward-line call must be in sync with how |
| 324 | ;; `rmail-mime-insert-tagline' formats the tagline. The |
| 325 | ;; body begins after the empty line that ends the tagline. |
| 326 | (forward-line 3)) |
| 327 | (setq body-beg (point)) |
| 328 | (if (>= pos body-beg) |
| 329 | (setq index 3)) |
| 330 | ;; If the body is displayed, find its end. |
| 331 | (if (rmail-mime-display-body current) |
| 332 | (let ((tag (aref (rmail-mime-entity-tagline entity) 0)) |
| 333 | tag2) |
| 334 | (setq end (next-single-property-change beg 'rmail-mime-entity |
| 335 | nil (point-max))) |
| 336 | ;; `tag' is either an empty string or "/n" where n is |
| 337 | ;; the number of the part of the multipart MIME message. |
| 338 | ;; The loop below finds the next location whose |
| 339 | ;; `rmail-mime-entity' property specifies a tag of a |
| 340 | ;; different value. |
| 341 | (while (and (< end (point-max)) |
| 342 | (setq entity (get-text-property end 'rmail-mime-entity) |
| 343 | tag2 (aref (rmail-mime-entity-tagline entity) 0)) |
| 344 | (and (> (length tag2) 0) |
| 345 | (eq (string-match tag tag2) 0))) |
| 346 | (setq end (next-single-property-change end 'rmail-mime-entity |
| 347 | nil (point-max))))) |
| 348 | (setq end body-beg)) |
| 349 | (vector index beg tagline-beg body-beg end))))) |
| 350 | |
| 351 | (defun rmail-mime-shown-mode (entity) |
| 352 | "Make MIME-entity ENTITY display in the default way." |
| 353 | (let ((new (aref (rmail-mime-entity-display entity) 1))) |
| 354 | (aset new 0 (aref (rmail-mime-entity-header entity) 2)) |
| 355 | (aset new 1 (aref (rmail-mime-entity-tagline entity) 2)) |
| 356 | (aset new 2 (aref (rmail-mime-entity-body entity) 2))) |
| 357 | (dolist (child (rmail-mime-entity-children entity)) |
| 358 | (rmail-mime-shown-mode child))) |
| 359 | |
| 360 | (defun rmail-mime-hidden-mode (entity) |
| 361 | "Make MIME-entity ENTITY display in hidden mode." |
| 362 | (let ((new (aref (rmail-mime-entity-display entity) 1))) |
| 363 | (aset new 0 nil) |
| 364 | (aset new 1 t) |
| 365 | (aset new 2 nil)) |
| 366 | (dolist (child (rmail-mime-entity-children entity)) |
| 367 | (rmail-mime-hidden-mode child))) |
| 368 | |
| 369 | (defun rmail-mime-raw-mode (entity) |
| 370 | "Make MIME-entity ENTITY display in raw mode." |
| 371 | (let ((new (aref (rmail-mime-entity-display entity) 1))) |
| 372 | (aset new 0 'raw) |
| 373 | (aset new 1 nil) |
| 374 | (aset new 2 'raw)) |
| 375 | (dolist (child (rmail-mime-entity-children entity)) |
| 376 | (rmail-mime-raw-mode child))) |
| 377 | |
| 378 | (defun rmail-mime-toggle-raw (&optional state) |
| 379 | "Toggle on and off the raw display mode of MIME-entity at point. |
| 380 | With optional argument STATE, force the specified display mode. |
| 381 | Use `raw' for raw mode, and any other non-nil value for decoded mode." |
| 382 | (let* ((pos (if (eobp) (1- (point-max)) (point))) |
| 383 | (entity (get-text-property pos 'rmail-mime-entity)) |
| 384 | (current (aref (rmail-mime-entity-display entity) 0)) |
| 385 | (segment (rmail-mime-entity-segment pos entity))) |
| 386 | (if (or (eq state 'raw) |
| 387 | (and (not state) |
| 388 | (not (eq (rmail-mime-display-header current) 'raw)))) |
| 389 | ;; Enter the raw mode. |
| 390 | (rmail-mime-raw-mode entity) |
| 391 | ;; Enter the shown mode. |
| 392 | (rmail-mime-shown-mode entity)) |
| 393 | (let ((inhibit-read-only t) |
| 394 | (modified (buffer-modified-p))) |
| 395 | (save-excursion |
| 396 | (goto-char (aref segment 1)) |
| 397 | (rmail-mime-insert entity) |
| 398 | (restore-buffer-modified-p modified))))) |
| 399 | |
| 400 | (defun rmail-mime-toggle-hidden () |
| 401 | "Hide or show the body of the MIME-entity at point." |
| 402 | (interactive) |
| 403 | (when (rmail-mime-message-p) |
| 404 | (let* ((rmail-mime-mbox-buffer rmail-view-buffer) |
| 405 | (rmail-mime-view-buffer (current-buffer)) |
| 406 | (pos (if (eobp) (1- (point-max)) (point))) |
| 407 | (entity (get-text-property pos 'rmail-mime-entity)) |
| 408 | (current (aref (rmail-mime-entity-display entity) 0)) |
| 409 | (segment (rmail-mime-entity-segment pos entity))) |
| 410 | (if (rmail-mime-display-body current) |
| 411 | ;; Enter the hidden mode. |
| 412 | (progn |
| 413 | ;; If point is in the body part, move it to the tagline |
| 414 | ;; (or the header if tagline is not displayed). |
| 415 | (if (= (aref segment 0) 3) |
| 416 | (goto-char (aref segment 2))) |
| 417 | (rmail-mime-hidden-mode entity) |
| 418 | ;; If the current entity is the topmost one, display the |
| 419 | ;; header. |
| 420 | (if (and rmail-mime-mbox-buffer (= (aref segment 1) (point-min))) |
| 421 | (let ((new (aref (rmail-mime-entity-display entity) 1))) |
| 422 | (aset new 0 t)))) |
| 423 | ;; Query as a warning before showing if truncated. |
| 424 | (if (and (not (stringp entity)) |
| 425 | (rmail-mime-entity-truncated entity)) |
| 426 | (unless (y-or-n-p "This entity is truncated; show anyway? ") |
| 427 | (error "Aborted"))) |
| 428 | ;; Enter the shown mode. |
| 429 | (rmail-mime-shown-mode entity) |
| 430 | ;; Force this body shown. |
| 431 | (aset (aref (rmail-mime-entity-display entity) 1) 2 t)) |
| 432 | (let ((inhibit-read-only t) |
| 433 | (modified (buffer-modified-p)) |
| 434 | (rmail-mime-mbox-buffer rmail-view-buffer) |
| 435 | (rmail-mime-view-buffer rmail-buffer)) |
| 436 | (save-excursion |
| 437 | (goto-char (aref segment 1)) |
| 438 | (rmail-mime-insert entity) |
| 439 | (restore-buffer-modified-p modified)))))) |
| 440 | |
| 441 | (define-key rmail-mode-map "\t" 'forward-button) |
| 442 | (define-key rmail-mode-map [backtab] 'backward-button) |
| 443 | (define-key rmail-mode-map "\r" 'rmail-mime-toggle-hidden) |
| 444 | |
| 445 | ;;; Handlers |
| 446 | |
| 447 | (defun rmail-mime-insert-tagline (entity &rest item-list) |
| 448 | "Insert a tag line for MIME-entity ENTITY. |
| 449 | ITEM-LIST is a list of strings or button-elements (list) to add |
| 450 | to the tag line." |
| 451 | ;; Precede the tagline by an empty line to make it a separate |
| 452 | ;; paragraph, so that it is aligned to the left margin of the window |
| 453 | ;; even if preceded by a right-to-left paragraph. |
| 454 | (insert "\n[") |
| 455 | (let ((tag (aref (rmail-mime-entity-tagline entity) 0))) |
| 456 | (if (> (length tag) 0) (insert (substring tag 1) ":"))) |
| 457 | (insert (car (rmail-mime-entity-type entity)) " ") |
| 458 | (insert-button (let ((new (aref (rmail-mime-entity-display entity) 1))) |
| 459 | (if (rmail-mime-display-body new) "Hide" "Show")) |
| 460 | :type 'rmail-mime-toggle |
| 461 | 'help-echo "mouse-2, RET: Toggle show/hide") |
| 462 | (dolist (item item-list) |
| 463 | (when item |
| 464 | (if (stringp item) |
| 465 | (insert item) |
| 466 | (apply 'insert-button item)))) |
| 467 | ;; Follow the tagline by an empty line to make it a separate |
| 468 | ;; paragraph, so that the paragraph direction of the following text |
| 469 | ;; is determined based on that text. |
| 470 | (insert "]\n\n")) |
| 471 | |
| 472 | (defun rmail-mime-update-tagline (entity) |
| 473 | "Update the current tag line for MIME-entity ENTITY." |
| 474 | (let ((inhibit-read-only t) |
| 475 | (modified (buffer-modified-p)) |
| 476 | ;; If we are going to show the body, the new button label is |
| 477 | ;; "Hide". Otherwise, it's "Show". |
| 478 | (label (if (aref (aref (rmail-mime-entity-display entity) 1) 2) "Hide" |
| 479 | "Show")) |
| 480 | (button (next-button (point)))) |
| 481 | ;; Go to the second character of the button "Show" or "Hide". |
| 482 | (goto-char (1+ (button-start button))) |
| 483 | (setq button (button-at (point))) |
| 484 | (save-excursion |
| 485 | (insert label) |
| 486 | (delete-region (point) (button-end button))) |
| 487 | (delete-region (button-start button) (point)) |
| 488 | (put-text-property (point) (button-end button) 'rmail-mime-entity entity) |
| 489 | (restore-buffer-modified-p modified) |
| 490 | ;; The following call to forward-line must be in sync with how |
| 491 | ;; rmail-mime-insert-tagline formats the tagline. |
| 492 | (forward-line 2))) |
| 493 | |
| 494 | (defun rmail-mime-insert-header (header) |
| 495 | "Decode and insert a MIME-entity header HEADER in the current buffer. |
| 496 | HEADER is a vector [BEG END DEFAULT-STATUS]. |
| 497 | See `rmail-mime-entity' for details." |
| 498 | (let ((pos (point)) |
| 499 | (last-coding-system-used nil)) |
| 500 | (save-restriction |
| 501 | (narrow-to-region pos pos) |
| 502 | (with-current-buffer rmail-mime-mbox-buffer |
| 503 | (let ((rmail-buffer rmail-mime-mbox-buffer) |
| 504 | (rmail-view-buffer rmail-mime-view-buffer)) |
| 505 | (save-excursion |
| 506 | (goto-char (aref header 0)) |
| 507 | (rmail-copy-headers (point) (aref header 1))))) |
| 508 | (rfc2047-decode-region pos (point)) |
| 509 | (if (and last-coding-system-used (not rmail-mime-coding-system)) |
| 510 | (setq rmail-mime-coding-system (cons last-coding-system-used nil))) |
| 511 | (goto-char (point-min)) |
| 512 | (rmail-highlight-headers) |
| 513 | (goto-char (point-max)) |
| 514 | (insert "\n")))) |
| 515 | |
| 516 | (defun rmail-mime-find-header-encoding (header) |
| 517 | "Return the last coding system used to decode HEADER. |
| 518 | HEADER is a header component of a MIME-entity object (see |
| 519 | `rmail-mime-entity')." |
| 520 | (with-temp-buffer |
| 521 | (let ((buf (current-buffer))) |
| 522 | (with-current-buffer rmail-mime-mbox-buffer |
| 523 | (let ((last-coding-system-used nil) |
| 524 | (rmail-buffer rmail-mime-mbox-buffer) |
| 525 | (rmail-view-buffer buf)) |
| 526 | (save-excursion |
| 527 | (goto-char (aref header 0)) |
| 528 | (rmail-copy-headers (point) (aref header 1))))) |
| 529 | (rfc2047-decode-region (point-min) (point-max)) |
| 530 | last-coding-system-used))) |
| 531 | |
| 532 | (defun rmail-mime-text-handler (content-type |
| 533 | content-disposition |
| 534 | content-transfer-encoding) |
| 535 | "Handle the current buffer as a plain text MIME part." |
| 536 | (rmail-mime-insert-text |
| 537 | (rmail-mime-entity content-type content-disposition |
| 538 | content-transfer-encoding |
| 539 | (vector (vector nil nil nil) (vector nil nil t)) |
| 540 | (vector nil nil nil) (vector "" (cons nil nil) t) |
| 541 | (vector nil nil nil) nil 'rmail-mime-insert-text)) |
| 542 | t) |
| 543 | |
| 544 | (defun rmail-mime-insert-decoded-text (entity) |
| 545 | "Decode and insert the text body of MIME-entity ENTITY." |
| 546 | (let* ((content-type (rmail-mime-entity-type entity)) |
| 547 | (charset (cdr (assq 'charset (cdr content-type)))) |
| 548 | (coding-system (if charset |
| 549 | (coding-system-from-name charset))) |
| 550 | (body (rmail-mime-entity-body entity)) |
| 551 | (pos (point))) |
| 552 | (or (and coding-system (coding-system-p coding-system)) |
| 553 | (setq coding-system 'undecided)) |
| 554 | (if (stringp (aref body 0)) |
| 555 | (insert (aref body 0)) |
| 556 | (let ((transfer-encoding (rmail-mime-entity-transfer-encoding entity))) |
| 557 | (insert-buffer-substring rmail-mime-mbox-buffer |
| 558 | (aref body 0) (aref body 1)) |
| 559 | (cond ((string= transfer-encoding "base64") |
| 560 | (ignore-errors (base64-decode-region pos (point)))) |
| 561 | ((string= transfer-encoding "quoted-printable") |
| 562 | (quoted-printable-decode-region pos (point)))))) |
| 563 | (decode-coding-region pos (point) coding-system) |
| 564 | (if (and |
| 565 | (or (not rmail-mime-coding-system) (consp rmail-mime-coding-system)) |
| 566 | (not (eq (coding-system-base coding-system) 'us-ascii))) |
| 567 | (setq rmail-mime-coding-system coding-system)) |
| 568 | (or (bolp) (insert "\n")))) |
| 569 | |
| 570 | (defun rmail-mime-insert-text (entity) |
| 571 | "Presentation handler for a plain text MIME entity." |
| 572 | (let ((current (aref (rmail-mime-entity-display entity) 0)) |
| 573 | (new (aref (rmail-mime-entity-display entity) 1)) |
| 574 | (header (rmail-mime-entity-header entity)) |
| 575 | (tagline (rmail-mime-entity-tagline entity)) |
| 576 | (body (rmail-mime-entity-body entity)) |
| 577 | (beg (point)) |
| 578 | (segment (rmail-mime-entity-segment (point) entity))) |
| 579 | |
| 580 | (or (integerp (aref body 0)) (markerp (aref body 0)) |
| 581 | (let ((data (buffer-string))) |
| 582 | (aset body 0 data) |
| 583 | (delete-region (point-min) (point-max)))) |
| 584 | |
| 585 | ;; header |
| 586 | (if (eq (rmail-mime-display-header current) |
| 587 | (rmail-mime-display-header new)) |
| 588 | (goto-char (aref segment 2)) |
| 589 | (if (rmail-mime-display-header current) |
| 590 | (delete-char (- (aref segment 2) (aref segment 1)))) |
| 591 | (if (rmail-mime-display-header new) |
| 592 | (rmail-mime-insert-header header))) |
| 593 | ;; tagline |
| 594 | (if (eq (rmail-mime-display-tagline current) |
| 595 | (rmail-mime-display-tagline new)) |
| 596 | (if (or (not (rmail-mime-display-tagline current)) |
| 597 | (eq (rmail-mime-display-body current) |
| 598 | (rmail-mime-display-body new))) |
| 599 | (forward-char (- (aref segment 3) (aref segment 2))) |
| 600 | (rmail-mime-update-tagline entity)) |
| 601 | (if (rmail-mime-display-tagline current) |
| 602 | (delete-char (- (aref segment 3) (aref segment 2)))) |
| 603 | (if (rmail-mime-display-tagline new) |
| 604 | (rmail-mime-insert-tagline entity))) |
| 605 | ;; body |
| 606 | (if (eq (rmail-mime-display-body current) |
| 607 | (rmail-mime-display-body new)) |
| 608 | (forward-char (- (aref segment 4) (aref segment 3))) |
| 609 | (if (rmail-mime-display-body current) |
| 610 | (delete-char (- (aref segment 4) (aref segment 3)))) |
| 611 | (if (rmail-mime-display-body new) |
| 612 | (rmail-mime-insert-decoded-text entity))) |
| 613 | (put-text-property beg (point) 'rmail-mime-entity entity))) |
| 614 | |
| 615 | (defun rmail-mime-insert-image (entity) |
| 616 | "Decode and insert the image body of MIME-entity ENTITY." |
| 617 | (let* ((content-type (car (rmail-mime-entity-type entity))) |
| 618 | (bulk-data (aref (rmail-mime-entity-tagline entity) 1)) |
| 619 | (body (rmail-mime-entity-body entity)) |
| 620 | data) |
| 621 | (if (stringp (aref body 0)) |
| 622 | (setq data (aref body 0)) |
| 623 | (let ((rmail-mime-mbox-buffer rmail-view-buffer) |
| 624 | (transfer-encoding (rmail-mime-entity-transfer-encoding entity))) |
| 625 | (with-temp-buffer |
| 626 | (set-buffer-multibyte nil) |
| 627 | (setq buffer-undo-list t) |
| 628 | (insert-buffer-substring rmail-mime-mbox-buffer |
| 629 | (aref body 0) (aref body 1)) |
| 630 | (cond ((string= transfer-encoding "base64") |
| 631 | (ignore-errors (base64-decode-region (point-min) (point-max)))) |
| 632 | ((string= transfer-encoding "quoted-printable") |
| 633 | (quoted-printable-decode-region (point-min) (point-max)))) |
| 634 | (setq data |
| 635 | (buffer-substring-no-properties (point-min) (point-max)))))) |
| 636 | (insert-image (create-image data (cdr bulk-data) t)) |
| 637 | (insert "\n"))) |
| 638 | |
| 639 | (defun rmail-mime-toggle-button (button) |
| 640 | "Hide or show the body of the MIME-entity associated with BUTTON." |
| 641 | (save-excursion |
| 642 | (goto-char (button-start button)) |
| 643 | (rmail-mime-toggle-hidden))) |
| 644 | |
| 645 | (define-button-type 'rmail-mime-toggle 'action 'rmail-mime-toggle-button) |
| 646 | |
| 647 | |
| 648 | (defun rmail-mime-bulk-handler (content-type |
| 649 | content-disposition |
| 650 | content-transfer-encoding) |
| 651 | "Handle the current buffer as an attachment to download. |
| 652 | For images that Emacs is capable of displaying, the behavior |
| 653 | depends upon the value of `rmail-mime-show-images'." |
| 654 | (rmail-mime-insert-bulk |
| 655 | (rmail-mime-entity content-type content-disposition content-transfer-encoding |
| 656 | (vector (vector nil nil nil) (vector nil t nil)) |
| 657 | (vector nil nil nil) (vector "" (cons nil nil) t) |
| 658 | (vector nil nil nil) nil 'rmail-mime-insert-bulk))) |
| 659 | |
| 660 | (defun rmail-mime-set-bulk-data (entity) |
| 661 | "Setup the information about the attachment object for MIME-entity ENTITY. |
| 662 | The value is non-nil if and only if the attachment object should be shown |
| 663 | directly." |
| 664 | (let ((content-type (car (rmail-mime-entity-type entity))) |
| 665 | (size (cdr (assq 'size (cdr (rmail-mime-entity-disposition entity))))) |
| 666 | (bulk-data (aref (rmail-mime-entity-tagline entity) 1)) |
| 667 | (body (rmail-mime-entity-body entity)) |
| 668 | type to-show) |
| 669 | (cond (size |
| 670 | (setq size (string-to-number size))) |
| 671 | ((stringp (aref body 0)) |
| 672 | (setq size (length (aref body 0)))) |
| 673 | (t |
| 674 | ;; Rough estimation of the size. |
| 675 | (let ((encoding (rmail-mime-entity-transfer-encoding entity))) |
| 676 | (setq size (- (aref body 1) (aref body 0))) |
| 677 | (cond ((string= encoding "base64") |
| 678 | (setq size (/ (* size 3) 4))) |
| 679 | ((string= encoding "quoted-printable") |
| 680 | (setq size (/ (* size 7) 3))))))) |
| 681 | |
| 682 | (cond |
| 683 | ((string-match "text/" content-type) |
| 684 | (setq type 'text)) |
| 685 | ((string-match "image/\\(.*\\)" content-type) |
| 686 | (setq type (image-type-from-file-name |
| 687 | (concat "." (match-string 1 content-type)))) |
| 688 | (if (and (memq type image-types) |
| 689 | (image-type-available-p type)) |
| 690 | (if (and rmail-mime-show-images |
| 691 | (not (eq rmail-mime-show-images 'button)) |
| 692 | (or (not (numberp rmail-mime-show-images)) |
| 693 | (< size rmail-mime-show-images))) |
| 694 | (setq to-show t)) |
| 695 | (setq type nil)))) |
| 696 | (setcar bulk-data size) |
| 697 | (setcdr bulk-data type) |
| 698 | to-show)) |
| 699 | |
| 700 | (defun rmail-mime-insert-bulk (entity) |
| 701 | "Presentation handler for an attachment MIME entity." |
| 702 | (let* ((content-type (rmail-mime-entity-type entity)) |
| 703 | (content-disposition (rmail-mime-entity-disposition entity)) |
| 704 | (current (aref (rmail-mime-entity-display entity) 0)) |
| 705 | (new (aref (rmail-mime-entity-display entity) 1)) |
| 706 | (header (rmail-mime-entity-header entity)) |
| 707 | (tagline (rmail-mime-entity-tagline entity)) |
| 708 | (bulk-data (aref tagline 1)) |
| 709 | (body (rmail-mime-entity-body entity)) |
| 710 | ;; Find the default directory for this media type. |
| 711 | (directory (catch 'directory |
| 712 | (dolist (entry rmail-mime-attachment-dirs-alist) |
| 713 | (when (string-match (car entry) (car content-type)) |
| 714 | (dolist (dir (cdr entry)) |
| 715 | (when (file-directory-p dir) |
| 716 | (throw 'directory dir))))))) |
| 717 | (filename (or (cdr (assq 'name (cdr content-type))) |
| 718 | (cdr (assq 'filename (cdr content-disposition))) |
| 719 | "noname")) |
| 720 | (units '(B kB MB GB)) |
| 721 | (segment (rmail-mime-entity-segment (point) entity)) |
| 722 | beg data size) |
| 723 | |
| 724 | (if (or (integerp (aref body 0)) (markerp (aref body 0))) |
| 725 | (setq data entity |
| 726 | size (car bulk-data)) |
| 727 | (if (stringp (aref body 0)) |
| 728 | (setq data (aref body 0)) |
| 729 | (setq data (string-as-unibyte (buffer-string))) |
| 730 | (aset body 0 data) |
| 731 | (rmail-mime-set-bulk-data entity) |
| 732 | (delete-region (point-min) (point-max))) |
| 733 | (setq size (length data))) |
| 734 | (while (and (> size 1024.0) ; cribbed from gnus-agent-expire-done-message |
| 735 | (cdr units)) |
| 736 | (setq size (/ size 1024.0) |
| 737 | units (cdr units))) |
| 738 | |
| 739 | (setq beg (point)) |
| 740 | |
| 741 | ;; header |
| 742 | (if (eq (rmail-mime-display-header current) |
| 743 | (rmail-mime-display-header new)) |
| 744 | (goto-char (aref segment 2)) |
| 745 | (if (rmail-mime-display-header current) |
| 746 | (delete-char (- (aref segment 2) (aref segment 1)))) |
| 747 | (if (rmail-mime-display-header new) |
| 748 | (rmail-mime-insert-header header))) |
| 749 | |
| 750 | ;; tagline |
| 751 | (if (eq (rmail-mime-display-tagline current) |
| 752 | (rmail-mime-display-tagline new)) |
| 753 | (if (or (not (rmail-mime-display-tagline current)) |
| 754 | (eq (rmail-mime-display-body current) |
| 755 | (rmail-mime-display-body new))) |
| 756 | (forward-char (- (aref segment 3) (aref segment 2))) |
| 757 | (rmail-mime-update-tagline entity)) |
| 758 | (if (rmail-mime-display-tagline current) |
| 759 | (delete-char (- (aref segment 3) (aref segment 2)))) |
| 760 | (if (rmail-mime-display-tagline new) |
| 761 | (rmail-mime-insert-tagline |
| 762 | entity |
| 763 | " Save:" |
| 764 | (list filename |
| 765 | :type 'rmail-mime-save |
| 766 | 'help-echo "mouse-2, RET: Save attachment" |
| 767 | 'filename filename |
| 768 | 'directory (file-name-as-directory directory) |
| 769 | 'data data) |
| 770 | (format " (%.0f%s)" size (car units)) |
| 771 | ;; We don't need this button because the "type" string of a |
| 772 | ;; tagline is the button to do this. |
| 773 | ;; (if (cdr bulk-data) |
| 774 | ;; " ") |
| 775 | ;; (if (cdr bulk-data) |
| 776 | ;; (list "Toggle show/hide" |
| 777 | ;; :type 'rmail-mime-image |
| 778 | ;; 'help-echo "mouse-2, RET: Toggle show/hide" |
| 779 | ;; 'image-type (cdr bulk-data) |
| 780 | ;; 'image-data data)) |
| 781 | ))) |
| 782 | ;; body |
| 783 | (if (eq (rmail-mime-display-body current) |
| 784 | (rmail-mime-display-body new)) |
| 785 | (forward-char (- (aref segment 4) (aref segment 3))) |
| 786 | (if (rmail-mime-display-body current) |
| 787 | (delete-char (- (aref segment 4) (aref segment 3)))) |
| 788 | (if (rmail-mime-display-body new) |
| 789 | (cond ((eq (cdr bulk-data) 'text) |
| 790 | (rmail-mime-insert-decoded-text entity)) |
| 791 | ((cdr bulk-data) |
| 792 | (rmail-mime-insert-image entity)) |
| 793 | (t |
| 794 | ;; As we don't know how to display the body, just |
| 795 | ;; insert it as a text. |
| 796 | (rmail-mime-insert-decoded-text entity))))) |
| 797 | (put-text-property beg (point) 'rmail-mime-entity entity))) |
| 798 | |
| 799 | (defun rmail-mime-multipart-handler (content-type |
| 800 | content-disposition |
| 801 | content-transfer-encoding) |
| 802 | "Handle the current buffer as a multipart MIME body. |
| 803 | The current buffer should be narrowed to the body. CONTENT-TYPE, |
| 804 | CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values |
| 805 | of the respective parsed headers. See `rmail-mime-handle' for their |
| 806 | format." |
| 807 | (rmail-mime-process-multipart |
| 808 | content-type content-disposition content-transfer-encoding nil) |
| 809 | t) |
| 810 | |
| 811 | (defun rmail-mime-process-multipart (content-type |
| 812 | content-disposition |
| 813 | content-transfer-encoding |
| 814 | parse-tag) |
| 815 | "Process the current buffer as a multipart MIME body. |
| 816 | |
| 817 | If PARSE-TAG is nil, modify the current buffer directly for |
| 818 | showing the MIME body and return nil. |
| 819 | |
| 820 | Otherwise, PARSE-TAG is a string indicating the depth and index |
| 821 | number of the entity. In this case, parse the current buffer and |
| 822 | return a list of MIME-entity objects. |
| 823 | |
| 824 | The other arguments are the same as `rmail-mime-multipart-handler'." |
| 825 | ;; Some MUAs start boundaries with "--", while it should start |
| 826 | ;; with "CRLF--", as defined by RFC 2046: |
| 827 | ;; The boundary delimiter MUST occur at the beginning of a line, |
| 828 | ;; i.e., following a CRLF, and the initial CRLF is considered to |
| 829 | ;; be attached to the boundary delimiter line rather than part |
| 830 | ;; of the preceding part. |
| 831 | ;; We currently don't handle that. |
| 832 | (let ((boundary (cdr (assq 'boundary content-type))) |
| 833 | (subtype (cadr (split-string (car content-type) "/"))) |
| 834 | (index 0) |
| 835 | beg end next entities truncated) |
| 836 | (unless boundary |
| 837 | (rmail-mm-get-boundary-error-message |
| 838 | "No boundary defined" content-type content-disposition |
| 839 | content-transfer-encoding)) |
| 840 | (setq boundary (concat "\n--" boundary)) |
| 841 | ;; Hide the body before the first bodypart |
| 842 | (goto-char (point-min)) |
| 843 | (when (and (search-forward boundary nil t) |
| 844 | (looking-at "[ \t]*\n")) |
| 845 | (if parse-tag |
| 846 | (narrow-to-region (match-end 0) (point-max)) |
| 847 | (delete-region (point-min) (match-end 0)))) |
| 848 | |
| 849 | ;; Change content-type to the proper default one for the children. |
| 850 | (cond ((string-match "mixed" subtype) |
| 851 | (setq content-type '("text/plain"))) |
| 852 | ((string-match "digest" subtype) |
| 853 | (setq content-type '("message/rfc822"))) |
| 854 | (t |
| 855 | (setq content-type nil))) |
| 856 | |
| 857 | ;; Loop over all body parts, where beg points at the beginning of |
| 858 | ;; the part and end points at the end of the part. next points at |
| 859 | ;; the beginning of the next part. The current point is just |
| 860 | ;; after the boundary tag. |
| 861 | (setq beg (point-min)) |
| 862 | |
| 863 | (while (or (and (search-forward boundary nil t) |
| 864 | (setq truncated nil end (match-beginning 0))) |
| 865 | ;; If the boundary does not appear at all, |
| 866 | ;; the message was truncated. |
| 867 | ;; Handle the rest of the truncated message |
| 868 | ;; (if it isn't empty) by pretending that the boundary |
| 869 | ;; appears at the end of the message. |
| 870 | (and (save-excursion |
| 871 | (skip-chars-forward "\n") |
| 872 | (> (point-max) (point))) |
| 873 | (setq truncated t end (point-max)))) |
| 874 | ;; If this is the last boundary according to RFC 2046, hide the |
| 875 | ;; epilogue, else hide the boundary only. Use a marker for |
| 876 | ;; `next' because `rmail-mime-show' may change the buffer. |
| 877 | (cond ((looking-at "--[ \t]*$") |
| 878 | (setq next (point-max-marker))) |
| 879 | ((looking-at "[ \t]*\n") |
| 880 | (setq next (copy-marker (match-end 0) t))) |
| 881 | (truncated |
| 882 | ;; We're handling what's left of a truncated message. |
| 883 | (setq next (point-max-marker))) |
| 884 | (t |
| 885 | ;; The original code signaled an error as below, but |
| 886 | ;; this line may be a boundary of nested multipart. So, |
| 887 | ;; we just set `next' to nil to skip this line |
| 888 | ;; (rmail-mm-get-boundary-error-message |
| 889 | ;; "Malformed boundary" content-type content-disposition |
| 890 | ;; content-transfer-encoding) |
| 891 | (setq next nil))) |
| 892 | |
| 893 | (when next |
| 894 | (setq index (1+ index)) |
| 895 | ;; Handle the part. |
| 896 | (if parse-tag |
| 897 | (save-restriction |
| 898 | (narrow-to-region beg end) |
| 899 | (let ((child (rmail-mime-process |
| 900 | nil (format "%s/%d" parse-tag index) |
| 901 | content-type content-disposition))) |
| 902 | ;; Display a tagline. |
| 903 | (aset (aref (rmail-mime-entity-display child) 1) 1 |
| 904 | (aset (rmail-mime-entity-tagline child) 2 t)) |
| 905 | (rmail-mime-entity-set-truncated child truncated) |
| 906 | (push child entities))) |
| 907 | |
| 908 | (delete-region end next) |
| 909 | (save-restriction |
| 910 | (narrow-to-region beg end) |
| 911 | (rmail-mime-show))) |
| 912 | (goto-char (setq beg next)))) |
| 913 | |
| 914 | (when parse-tag |
| 915 | (setq entities (nreverse entities)) |
| 916 | (if (string-match "alternative" subtype) |
| 917 | ;; Find the best entity to show, and hide all the others. |
| 918 | (let (best second) |
| 919 | (dolist (child entities) |
| 920 | (if (string= (or (car (rmail-mime-entity-disposition child)) |
| 921 | (car content-disposition)) |
| 922 | "inline") |
| 923 | (if (string-match "text/plain" |
| 924 | (car (rmail-mime-entity-type child))) |
| 925 | (setq best child) |
| 926 | (if (string-match "text/.*" |
| 927 | (car (rmail-mime-entity-type child))) |
| 928 | (setq second child))))) |
| 929 | (or best (not second) (setq best second)) |
| 930 | (dolist (child entities) |
| 931 | (unless (eq best child) |
| 932 | (aset (rmail-mime-entity-body child) 2 nil) |
| 933 | (rmail-mime-hidden-mode child))))) |
| 934 | entities))) |
| 935 | |
| 936 | (defun rmail-mime-insert-multipart (entity) |
| 937 | "Presentation handler for a multipart MIME entity." |
| 938 | (let ((current (aref (rmail-mime-entity-display entity) 0)) |
| 939 | (new (aref (rmail-mime-entity-display entity) 1)) |
| 940 | (header (rmail-mime-entity-header entity)) |
| 941 | (tagline (rmail-mime-entity-tagline entity)) |
| 942 | (body (rmail-mime-entity-body entity)) |
| 943 | (beg (point)) |
| 944 | (segment (rmail-mime-entity-segment (point) entity))) |
| 945 | ;; header |
| 946 | (if (eq (rmail-mime-display-header current) |
| 947 | (rmail-mime-display-header new)) |
| 948 | (goto-char (aref segment 2)) |
| 949 | (if (rmail-mime-display-header current) |
| 950 | (delete-char (- (aref segment 2) (aref segment 1)))) |
| 951 | (if (rmail-mime-display-header new) |
| 952 | (rmail-mime-insert-header header))) |
| 953 | ;; tagline |
| 954 | (if (eq (rmail-mime-display-tagline current) |
| 955 | (rmail-mime-display-tagline new)) |
| 956 | (if (or (not (rmail-mime-display-tagline current)) |
| 957 | (eq (rmail-mime-display-body current) |
| 958 | (rmail-mime-display-body new))) |
| 959 | (forward-char (- (aref segment 3) (aref segment 2))) |
| 960 | (rmail-mime-update-tagline entity)) |
| 961 | (if (rmail-mime-display-tagline current) |
| 962 | (delete-char (- (aref segment 3) (aref segment 2)))) |
| 963 | (if (rmail-mime-display-tagline new) |
| 964 | (rmail-mime-insert-tagline entity))) |
| 965 | |
| 966 | (put-text-property beg (point) 'rmail-mime-entity entity) |
| 967 | |
| 968 | ;; body |
| 969 | (if (eq (rmail-mime-display-body current) |
| 970 | (rmail-mime-display-body new)) |
| 971 | (forward-char (- (aref segment 4) (aref segment 3))) |
| 972 | (dolist (child (rmail-mime-entity-children entity)) |
| 973 | (rmail-mime-insert child))) |
| 974 | entity)) |
| 975 | |
| 976 | ;;; Main code |
| 977 | |
| 978 | (defun rmail-mime-handle (content-type |
| 979 | content-disposition |
| 980 | content-transfer-encoding) |
| 981 | "Handle the current buffer as a MIME part. |
| 982 | The current buffer should be narrowed to the respective body, and |
| 983 | point should be at the beginning of the body. |
| 984 | |
| 985 | CONTENT-TYPE, CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING |
| 986 | are the values of the respective parsed headers. The latter should |
| 987 | be lower-case. The parsed headers for CONTENT-TYPE and CONTENT-DISPOSITION |
| 988 | have the form |
| 989 | |
| 990 | \(VALUE . ALIST) |
| 991 | |
| 992 | In other words: |
| 993 | |
| 994 | \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...) |
| 995 | |
| 996 | VALUE is a string and ATTRIBUTE is a symbol. |
| 997 | |
| 998 | Consider the following header, for example: |
| 999 | |
| 1000 | Content-Type: multipart/mixed; |
| 1001 | boundary=\"----=_NextPart_000_0104_01C617E4.BDEC4C40\" |
| 1002 | |
| 1003 | The parsed header value: |
| 1004 | |
| 1005 | \(\"multipart/mixed\" |
| 1006 | \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))" |
| 1007 | ;; Handle the content transfer encodings we know. Unknown transfer |
| 1008 | ;; encodings will be passed on to the various handlers. |
| 1009 | (cond ((string= content-transfer-encoding "base64") |
| 1010 | (when (ignore-errors |
| 1011 | (base64-decode-region (point) (point-max))) |
| 1012 | (setq content-transfer-encoding nil))) |
| 1013 | ((string= content-transfer-encoding "quoted-printable") |
| 1014 | (quoted-printable-decode-region (point) (point-max)) |
| 1015 | (setq content-transfer-encoding nil)) |
| 1016 | ((string= content-transfer-encoding "8bit") |
| 1017 | ;; FIXME: Is this the correct way? |
| 1018 | ;; No, of course not, it just means there's no decoding to do. |
| 1019 | ;; (set-buffer-multibyte nil) |
| 1020 | (setq content-transfer-encoding nil) |
| 1021 | )) |
| 1022 | ;; Inline stuff requires work. Attachments are handled by the bulk |
| 1023 | ;; handler. |
| 1024 | (if (string= "inline" (car content-disposition)) |
| 1025 | (let ((stop nil)) |
| 1026 | (dolist (entry rmail-mime-media-type-handlers-alist) |
| 1027 | (when (and (string-match (car entry) (car content-type)) (not stop)) |
| 1028 | (progn |
| 1029 | (setq stop (funcall (cadr entry) content-type |
| 1030 | content-disposition |
| 1031 | content-transfer-encoding)))))) |
| 1032 | ;; Everything else is an attachment. |
| 1033 | (rmail-mime-bulk-handler content-type |
| 1034 | content-disposition |
| 1035 | content-transfer-encoding)) |
| 1036 | (save-restriction |
| 1037 | (widen) |
| 1038 | (let ((entity (get-text-property (1- (point)) 'rmail-mime-entity)) |
| 1039 | current new) |
| 1040 | (when entity |
| 1041 | (setq current (aref (rmail-mime-entity-display entity) 0) |
| 1042 | new (aref (rmail-mime-entity-display entity) 1)) |
| 1043 | (dotimes (i 3) |
| 1044 | (aset current i (aref new i))))))) |
| 1045 | |
| 1046 | (defun rmail-mime-show (&optional show-headers) |
| 1047 | "Handle the current buffer as a MIME message. |
| 1048 | If SHOW-HEADERS is non-nil, then the headers of the current part |
| 1049 | will shown as usual for a MIME message. The headers are also |
| 1050 | shown for the content type message/rfc822. This function will be |
| 1051 | called recursively if multiple parts are available. |
| 1052 | |
| 1053 | The current buffer must contain a single message. It will be |
| 1054 | modified." |
| 1055 | (rmail-mime-process show-headers nil)) |
| 1056 | |
| 1057 | (defun rmail-mime-process (show-headers parse-tag &optional |
| 1058 | default-content-type |
| 1059 | default-content-disposition) |
| 1060 | (let ((end (point-min)) |
| 1061 | content-type |
| 1062 | content-transfer-encoding |
| 1063 | content-disposition) |
| 1064 | ;; `point-min' returns the beginning and `end' points at the end |
| 1065 | ;; of the headers. |
| 1066 | (goto-char (point-min)) |
| 1067 | ;; If we're showing a part without headers, then it will start |
| 1068 | ;; with a newline. |
| 1069 | (if (eq (char-after) ?\n) |
| 1070 | (setq end (1+ (point))) |
| 1071 | (when (search-forward "\n\n" nil t) |
| 1072 | (setq end (match-end 0)) |
| 1073 | (save-restriction |
| 1074 | (narrow-to-region (point-min) end) |
| 1075 | ;; FIXME: Default disposition of the multipart entities should |
| 1076 | ;; be inherited. |
| 1077 | (setq content-type |
| 1078 | (mail-fetch-field "Content-Type") |
| 1079 | content-transfer-encoding |
| 1080 | (mail-fetch-field "Content-Transfer-Encoding") |
| 1081 | content-disposition |
| 1082 | (mail-fetch-field "Content-Disposition"))))) |
| 1083 | ;; Per RFC 2045, C-T-E is case insensitive (bug#5070), but the others |
| 1084 | ;; are not completely so. Hopefully mail-header-parse-* DTRT. |
| 1085 | (if content-transfer-encoding |
| 1086 | (setq content-transfer-encoding (downcase content-transfer-encoding))) |
| 1087 | (setq content-type |
| 1088 | (if content-type |
| 1089 | (or (mail-header-parse-content-type content-type) |
| 1090 | '("text/plain")) |
| 1091 | (or default-content-type '("text/plain")))) |
| 1092 | (setq content-disposition |
| 1093 | (if content-disposition |
| 1094 | (mail-header-parse-content-disposition content-disposition) |
| 1095 | ;; If none specified, we are free to choose what we deem |
| 1096 | ;; suitable according to RFC 2183. We like inline. |
| 1097 | (or default-content-disposition '("inline")))) |
| 1098 | ;; Unrecognized disposition types are to be treated like |
| 1099 | ;; attachment according to RFC 2183. |
| 1100 | (unless (member (car content-disposition) '("inline" "attachment")) |
| 1101 | (setq content-disposition '("attachment"))) |
| 1102 | |
| 1103 | (if parse-tag |
| 1104 | (let* ((is-inline (string= (car content-disposition) "inline")) |
| 1105 | (hdr-end (copy-marker end)) |
| 1106 | (header (vector (point-min-marker) hdr-end nil)) |
| 1107 | (tagline (vector parse-tag (cons nil nil) t)) |
| 1108 | (body (vector hdr-end (point-max-marker) is-inline)) |
| 1109 | (new (vector (aref header 2) (aref tagline 2) (aref body 2))) |
| 1110 | children handler entity) |
| 1111 | (cond ((string-match "multipart/.*" (car content-type)) |
| 1112 | (save-restriction |
| 1113 | (narrow-to-region (1- end) (point-max)) |
| 1114 | (setq children (rmail-mime-process-multipart |
| 1115 | content-type |
| 1116 | content-disposition |
| 1117 | content-transfer-encoding |
| 1118 | parse-tag) |
| 1119 | handler 'rmail-mime-insert-multipart))) |
| 1120 | ((string-match "message/rfc822" (car content-type)) |
| 1121 | (save-restriction |
| 1122 | (narrow-to-region end (point-max)) |
| 1123 | (let* ((msg (rmail-mime-process t parse-tag |
| 1124 | '("text/plain") '("inline"))) |
| 1125 | (msg-new (aref (rmail-mime-entity-display msg) 1))) |
| 1126 | ;; Show header of the child. |
| 1127 | (aset msg-new 0 t) |
| 1128 | (aset (rmail-mime-entity-header msg) 2 t) |
| 1129 | ;; Hide tagline of the child. |
| 1130 | (aset msg-new 1 nil) |
| 1131 | (aset (rmail-mime-entity-tagline msg) 2 nil) |
| 1132 | (setq children (list msg) |
| 1133 | handler 'rmail-mime-insert-multipart)))) |
| 1134 | ((and is-inline (string-match "text/" (car content-type))) |
| 1135 | ;; Don't need a tagline. |
| 1136 | (aset new 1 (aset tagline 2 nil)) |
| 1137 | (setq handler 'rmail-mime-insert-text)) |
| 1138 | (t |
| 1139 | ;; Force hidden mode. |
| 1140 | (aset new 1 (aset tagline 2 t)) |
| 1141 | (aset new 2 (aset body 2 nil)) |
| 1142 | (setq handler 'rmail-mime-insert-bulk))) |
| 1143 | (setq entity (rmail-mime-entity content-type |
| 1144 | content-disposition |
| 1145 | content-transfer-encoding |
| 1146 | (vector (vector nil nil nil) new) |
| 1147 | header tagline body children handler)) |
| 1148 | (if (and (eq handler 'rmail-mime-insert-bulk) |
| 1149 | (rmail-mime-set-bulk-data entity)) |
| 1150 | ;; Show the body. |
| 1151 | (aset new 2 (aset body 2 t))) |
| 1152 | entity) |
| 1153 | |
| 1154 | ;; Hide headers and handle the part. |
| 1155 | (put-text-property (point-min) (point-max) 'rmail-mime-entity |
| 1156 | (rmail-mime-entity |
| 1157 | content-type content-disposition |
| 1158 | content-transfer-encoding |
| 1159 | (vector (vector 'raw nil 'raw) (vector 'raw nil 'raw)) |
| 1160 | (vector nil nil 'raw) (vector "" (cons nil nil) nil) |
| 1161 | (vector nil nil 'raw) nil nil)) |
| 1162 | (save-restriction |
| 1163 | (cond ((string= (car content-type) "message/rfc822") |
| 1164 | (narrow-to-region end (point-max))) |
| 1165 | ((not show-headers) |
| 1166 | (delete-region (point-min) end))) |
| 1167 | (rmail-mime-handle content-type content-disposition |
| 1168 | content-transfer-encoding))))) |
| 1169 | |
| 1170 | (defun rmail-mime-parse () |
| 1171 | "Parse the current Rmail message as a MIME message. |
| 1172 | The value is a MIME-entity object (see `rmail-mime-entity'). |
| 1173 | If an error occurs, return an error message string." |
| 1174 | (let ((rmail-mime-mbox-buffer (if (rmail-buffers-swapped-p) |
| 1175 | rmail-view-buffer |
| 1176 | (current-buffer)))) |
| 1177 | (condition-case err |
| 1178 | (with-current-buffer rmail-mime-mbox-buffer |
| 1179 | (save-excursion |
| 1180 | (goto-char (point-min)) |
| 1181 | (let* ((entity (rmail-mime-process t "" |
| 1182 | '("text/plain") '("inline"))) |
| 1183 | (new (aref (rmail-mime-entity-display entity) 1))) |
| 1184 | ;; Show header. |
| 1185 | (aset new 0 (aset (rmail-mime-entity-header entity) 2 t)) |
| 1186 | ;; Show tagline if and only if body is not shown. |
| 1187 | (if (aref new 2) |
| 1188 | (aset new 1 (aset (rmail-mime-entity-tagline entity) 2 nil)) |
| 1189 | (aset new 1 (aset (rmail-mime-entity-tagline entity) 2 t))) |
| 1190 | entity))) |
| 1191 | (error (format "%s" err))))) |
| 1192 | |
| 1193 | (defun rmail-mime-insert (entity) |
| 1194 | "Insert a MIME-entity ENTITY in the current buffer. |
| 1195 | |
| 1196 | This function will be called recursively if multiple parts are |
| 1197 | available." |
| 1198 | (let ((current (aref (rmail-mime-entity-display entity) 0)) |
| 1199 | (new (aref (rmail-mime-entity-display entity) 1))) |
| 1200 | (if (not (eq (rmail-mime-display-header new) 'raw)) |
| 1201 | ;; Not a raw-mode. Each handler should handle it. |
| 1202 | (funcall (rmail-mime-entity-handler entity) entity) |
| 1203 | (let ((header (rmail-mime-entity-header entity)) |
| 1204 | (tagline (rmail-mime-entity-tagline entity)) |
| 1205 | (body (rmail-mime-entity-body entity)) |
| 1206 | (beg (point)) |
| 1207 | (segment (rmail-mime-entity-segment (point) entity))) |
| 1208 | ;; header |
| 1209 | (if (eq (rmail-mime-display-header current) |
| 1210 | (rmail-mime-display-header new)) |
| 1211 | (goto-char (aref segment 2)) |
| 1212 | (if (rmail-mime-display-header current) |
| 1213 | (delete-char (- (aref segment 2) (aref segment 1)))) |
| 1214 | (insert-buffer-substring rmail-mime-mbox-buffer |
| 1215 | (aref header 0) (aref header 1))) |
| 1216 | ;; tagline |
| 1217 | (if (rmail-mime-display-tagline current) |
| 1218 | (delete-char (- (aref segment 3) (aref segment 2)))) |
| 1219 | ;; body |
| 1220 | (let ((children (rmail-mime-entity-children entity))) |
| 1221 | (if children |
| 1222 | (progn |
| 1223 | (put-text-property beg (point) 'rmail-mime-entity entity) |
| 1224 | (dolist (child children) |
| 1225 | (rmail-mime-insert child))) |
| 1226 | (if (eq (rmail-mime-display-body current) |
| 1227 | (rmail-mime-display-body new)) |
| 1228 | (forward-char (- (aref segment 4) (aref segment 3))) |
| 1229 | (if (rmail-mime-display-body current) |
| 1230 | (delete-char (- (aref segment 4) (aref segment 3)))) |
| 1231 | (insert-buffer-substring rmail-mime-mbox-buffer |
| 1232 | (aref body 0) (aref body 1)) |
| 1233 | (or (bolp) (insert "\n"))) |
| 1234 | (put-text-property beg (point) 'rmail-mime-entity entity))))) |
| 1235 | (dotimes (i 3) |
| 1236 | (aset current i (aref new i))))) |
| 1237 | |
| 1238 | (define-derived-mode rmail-mime-mode fundamental-mode "RMIME" |
| 1239 | "Major mode used in `rmail-mime' buffers." |
| 1240 | (setq font-lock-defaults '(rmail-font-lock-keywords t t nil nil))) |
| 1241 | |
| 1242 | ;;;###autoload |
| 1243 | (defun rmail-mime (&optional arg state) |
| 1244 | "Toggle the display of a MIME message. |
| 1245 | |
| 1246 | The actual behavior depends on the value of `rmail-enable-mime'. |
| 1247 | |
| 1248 | If `rmail-enable-mime' is non-nil (the default), this command toggles |
| 1249 | the display of a MIME message between decoded presentation form and |
| 1250 | raw data. With optional prefix argument ARG, it toggles the display only |
| 1251 | of the MIME entity at point, if there is one. The optional argument |
| 1252 | STATE forces a particular display state, rather than toggling. |
| 1253 | `raw' forces raw mode, any other non-nil value forces decoded mode. |
| 1254 | |
| 1255 | If `rmail-enable-mime' is nil, this creates a temporary \"*RMAIL*\" |
| 1256 | buffer holding a decoded copy of the message. Inline content-types are |
| 1257 | handled according to `rmail-mime-media-type-handlers-alist'. |
| 1258 | By default, this displays text and multipart messages, and offers to |
| 1259 | download attachments as specified by `rmail-mime-attachment-dirs-alist'. |
| 1260 | The arguments ARG and STATE have no effect in this case." |
| 1261 | (interactive (list current-prefix-arg nil)) |
| 1262 | (if rmail-enable-mime |
| 1263 | (with-current-buffer rmail-buffer |
| 1264 | (if (rmail-mime-message-p) |
| 1265 | (let ((rmail-mime-mbox-buffer rmail-view-buffer) |
| 1266 | (rmail-mime-view-buffer rmail-buffer) |
| 1267 | (entity (get-text-property |
| 1268 | (progn |
| 1269 | (or arg (goto-char (point-min))) |
| 1270 | (point)) 'rmail-mime-entity))) |
| 1271 | (if (or (not arg) entity) (rmail-mime-toggle-raw state))) |
| 1272 | (message "Not a MIME message, just toggling headers") |
| 1273 | (rmail-toggle-header))) |
| 1274 | (let* ((data (rmail-apply-in-message rmail-current-message 'buffer-string)) |
| 1275 | (buf (get-buffer-create "*RMAIL*")) |
| 1276 | (rmail-mime-mbox-buffer rmail-view-buffer) |
| 1277 | (rmail-mime-view-buffer buf)) |
| 1278 | (set-buffer buf) |
| 1279 | (setq buffer-undo-list t) |
| 1280 | (let ((inhibit-read-only t)) |
| 1281 | ;; Decoding the message in fundamental mode for speed, only |
| 1282 | ;; switching to rmail-mime-mode at the end for display. Eg |
| 1283 | ;; quoted-printable-decode-region gets very slow otherwise (Bug#4993). |
| 1284 | (fundamental-mode) |
| 1285 | (erase-buffer) |
| 1286 | (insert data) |
| 1287 | (rmail-mime-show t) |
| 1288 | (rmail-mime-mode) |
| 1289 | (set-buffer-modified-p nil)) |
| 1290 | (view-buffer buf)))) |
| 1291 | |
| 1292 | (defun rmail-mm-get-boundary-error-message (message type disposition encoding) |
| 1293 | "Return MESSAGE with more information on the main MIME components." |
| 1294 | (error "%s; type: %s; disposition: %s; encoding: %s" |
| 1295 | message type disposition encoding)) |
| 1296 | |
| 1297 | (defun rmail-show-mime () |
| 1298 | "Function to use for the value of `rmail-show-mime-function'." |
| 1299 | (let ((entity (rmail-mime-parse)) |
| 1300 | (rmail-mime-mbox-buffer rmail-buffer) |
| 1301 | (rmail-mime-view-buffer rmail-view-buffer) |
| 1302 | (rmail-mime-coding-system nil)) |
| 1303 | (if (vectorp entity) |
| 1304 | (with-current-buffer rmail-mime-view-buffer |
| 1305 | (erase-buffer) |
| 1306 | (rmail-mime-insert entity) |
| 1307 | (if (consp rmail-mime-coding-system) |
| 1308 | ;; Decoding is done by rfc2047-decode-region only for a |
| 1309 | ;; header. But, as the used coding system may have been |
| 1310 | ;; overridden by mm-charset-override-alist, we can't |
| 1311 | ;; trust (car rmail-mime-coding-system). So, here we |
| 1312 | ;; try the decoding again with mm-charset-override-alist |
| 1313 | ;; bound to nil. |
| 1314 | (let ((mm-charset-override-alist nil)) |
| 1315 | (setq rmail-mime-coding-system |
| 1316 | (rmail-mime-find-header-encoding |
| 1317 | (rmail-mime-entity-header entity))))) |
| 1318 | (set-buffer-file-coding-system |
| 1319 | (if rmail-mime-coding-system |
| 1320 | (coding-system-base rmail-mime-coding-system) |
| 1321 | 'undecided) |
| 1322 | t t)) |
| 1323 | ;; Decoding failed. ENTITY is an error message. Insert the |
| 1324 | ;; original message body as is, and show warning. |
| 1325 | (let ((region (with-current-buffer rmail-mime-mbox-buffer |
| 1326 | (goto-char (point-min)) |
| 1327 | (re-search-forward "^$" nil t) |
| 1328 | (forward-line 1) |
| 1329 | (vector (point-min) (point) (point-max))))) |
| 1330 | (with-current-buffer rmail-mime-view-buffer |
| 1331 | (let ((inhibit-read-only t)) |
| 1332 | (erase-buffer) |
| 1333 | (rmail-mime-insert-header region) |
| 1334 | (insert-buffer-substring rmail-mime-mbox-buffer |
| 1335 | (aref region 1) (aref region 2)))) |
| 1336 | (set-buffer-file-coding-system 'no-conversion t t) |
| 1337 | (message "MIME decoding failed: %s" entity))))) |
| 1338 | |
| 1339 | (setq rmail-show-mime-function 'rmail-show-mime) |
| 1340 | |
| 1341 | (defun rmail-insert-mime-forwarded-message (forward-buffer) |
| 1342 | "Insert the message in FORWARD-BUFFER as a forwarded message. |
| 1343 | This is the usual value of `rmail-insert-mime-forwarded-message-function'." |
| 1344 | (let ((message-buffer |
| 1345 | (with-current-buffer forward-buffer |
| 1346 | (if rmail-buffer-swapped |
| 1347 | forward-buffer |
| 1348 | rmail-view-buffer)))) |
| 1349 | (save-restriction |
| 1350 | (narrow-to-region (point) (point)) |
| 1351 | (message-forward-make-body-mime message-buffer)))) |
| 1352 | |
| 1353 | (setq rmail-insert-mime-forwarded-message-function |
| 1354 | 'rmail-insert-mime-forwarded-message) |
| 1355 | |
| 1356 | (defun rmail-insert-mime-resent-message (forward-buffer) |
| 1357 | "Function to set in `rmail-insert-mime-resent-message-function' (which see)." |
| 1358 | (insert-buffer-substring |
| 1359 | (with-current-buffer forward-buffer rmail-view-buffer)) |
| 1360 | (goto-char (point-min)) |
| 1361 | (when (looking-at "From ") |
| 1362 | (forward-line 1) |
| 1363 | (delete-region (point-min) (point)))) |
| 1364 | |
| 1365 | (setq rmail-insert-mime-resent-message-function |
| 1366 | 'rmail-insert-mime-resent-message) |
| 1367 | |
| 1368 | (defun rmail-search-mime-message (msg regexp) |
| 1369 | "Function to set in `rmail-search-mime-message-function' (which see)." |
| 1370 | (save-restriction |
| 1371 | (narrow-to-region (rmail-msgbeg msg) (rmail-msgend msg)) |
| 1372 | (let* ((rmail-mime-mbox-buffer (current-buffer)) |
| 1373 | (rmail-mime-view-buffer rmail-view-buffer) |
| 1374 | (header-end (save-excursion |
| 1375 | (re-search-forward "^$" nil 'move) (point))) |
| 1376 | (body-end (point-max)) |
| 1377 | (entity (rmail-mime-parse))) |
| 1378 | (or |
| 1379 | ;; At first, just search the headers. |
| 1380 | (with-temp-buffer |
| 1381 | (insert-buffer-substring rmail-mime-mbox-buffer nil header-end) |
| 1382 | (rfc2047-decode-region (point-min) (point)) |
| 1383 | (goto-char (point-min)) |
| 1384 | (re-search-forward regexp nil t)) |
| 1385 | ;; Next, search the body. |
| 1386 | (if (and entity |
| 1387 | ;; RMS: I am not sure why, but sometimes this is a string. |
| 1388 | (not (stringp entity)) |
| 1389 | (let* ((content-type (rmail-mime-entity-type entity)) |
| 1390 | (charset (cdr (assq 'charset (cdr content-type))))) |
| 1391 | (or (not (string-match "text/.*" (car content-type))) |
| 1392 | (and charset |
| 1393 | (not (string= (downcase charset) "us-ascii")))))) |
| 1394 | ;; Search the decoded MIME message. |
| 1395 | (with-temp-buffer |
| 1396 | (rmail-mime-insert entity) |
| 1397 | (goto-char (point-min)) |
| 1398 | (re-search-forward regexp nil t)) |
| 1399 | ;; Search the body without decoding. |
| 1400 | (goto-char header-end) |
| 1401 | (re-search-forward regexp nil t)))))) |
| 1402 | |
| 1403 | (setq rmail-search-mime-message-function 'rmail-search-mime-message) |
| 1404 | |
| 1405 | (provide 'rmailmm) |
| 1406 | |
| 1407 | ;; Local Variables: |
| 1408 | ;; generated-autoload-file: "rmail.el" |
| 1409 | ;; End: |
| 1410 | |
| 1411 | ;;; rmailmm.el ends here |