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