lisp/mail/rmailmm.el

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