code.delx.au - gnu-emacs/blob - lisp/mail/rmailmm.el

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