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  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   :type '(alist :key-type regexp :value-type (repeat function))
 102   :version "23.1"
 103   :group 'rmail-mime)
 104
 105 (defcustom rmail-mime-attachment-dirs-alist
 106   `(("text/.*" "~/Documents")
 107     ("image/.*" "~/Pictures")
 108     (".*" "~/Desktop" "~" ,temporary-file-directory))
 109   "Default directories to save attachments of various types into.
 110 This is an alist with elements of the form (REGEXP DIR ...).
 111 The first item is a regular expression matching a content-type.
 112 The remaining elements are directories, in order of decreasing preference.
 113 The first directory that exists is used."
 114   :type '(alist :key-type regexp :value-type (repeat directory))
 115   :version "23.1"
 116   :group 'rmail-mime)
 117
 118 (defcustom rmail-mime-show-images 'button
 119   "What to do with image attachments that Emacs is capable of displaying.
 120 If nil, do nothing special.  If `button', add an extra button
 121 that when pushed displays the image in the buffer.  If a number,
 122 automatically show images if they are smaller than that size (in
 123 bytes), otherwise add a display button.  Anything else means to
 124 automatically display the image in the buffer."
 125   :type '(choice (const :tag "Add button to view image" button)
 126                  (const :tag "No special treatment" nil)
 127                  (number :tag "Show if smaller than certain size")
 128                  (other :tag "Always show" show))
 129   :version "23.2"
 130   :group 'rmail-mime)
 131
 132 ;;; End of user options.
 133
 134 ;;; MIME-entity object
 135
 136 (defun rmail-mime-entity (type disposition transfer-encoding
 137                                header body children)
 138   "Retrun a newly created MIME-entity object.
 139
 140 A MIME-entity is a vector of 6 elements:
 141
 142   [ TYPE DISPOSITION TRANSFER-ENCODING HEADER BODY CHILDREN ]
 143
 144 TYPE and DISPOSITION correspond to MIME headers Content-Type: and
 145 Cotent-Disposition: respectively, and has this format:
 146
 147   \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)
 148
 149 VALUE is a string and ATTRIBUTE is a symbol.
 150
 151 Consider the following header, for example:
 152
 153 Content-Type: multipart/mixed;
 154         boundary=\"----=_NextPart_000_0104_01C617E4.BDEC4C40\"
 155
 156 The corresponding TYPE argument must be:
 157
 158 \(\"multipart/mixed\"
 159   \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))
 160
 161 TRANSFER-ENCODING corresponds to MIME header
 162 Content-Transfer-Encoding, and is a lowercased string.
 163
 164 HEADER and BODY are a cons (BEG . END), where BEG and END specify
 165 the region of the corresponding part in RMAIL's data (mbox)
 166 buffer.  BODY may be nil.  In that case, the current buffer is
 167 narrowed to the body part.
 168
 169 CHILDREN is a list of MIME-entities for a \"multipart\" entity, and
 170 nil for the other types."
 171   (vector type disposition transfer-encoding header body children))
 172
 173 ;; Accessors for a MIME-entity object.
 174 (defsubst rmail-mime-entity-type (entity) (aref entity 0))
 175 (defsubst rmail-mime-entity-disposition (entity) (aref entity 1))
 176 (defsubst rmail-mime-entity-transfer-encoding (entity) (aref entity 2))
 177 (defsubst rmail-mime-entity-header (entity) (aref entity 3))
 178 (defsubst rmail-mime-entity-body (entity) (aref entity 4))
 179 (defsubst rmail-mime-entity-children (entity) (aref entity 5))
 180
 181 ;;; Buttons
 182
 183 (defun rmail-mime-save (button)
 184   "Save the attachment using info in the BUTTON."
 185   (let* ((filename (button-get button 'filename))
 186          (directory (button-get button 'directory))
 187          (data (button-get button 'data))
 188          (mbox-buf rmail-view-buffer)
 189          (ofilename filename))
 190     (setq filename (expand-file-name
 191                     (read-file-name (format "Save as (default: %s): " filename)
 192                                     directory
 193                                     (expand-file-name filename directory))
 194                     directory))
 195     ;; If arg is just a directory, use the default file name, but in
 196     ;; that directory (copied from write-file).
 197     (if (file-directory-p filename)
 198         (setq filename (expand-file-name
 199                         (file-name-nondirectory ofilename)
 200                         (file-name-as-directory filename))))
 201     (with-temp-buffer
 202       (set-buffer-file-coding-system 'no-conversion)
 203       ;; Needed e.g. by jka-compr, so if the attachment is a compressed
 204       ;; file, the magic signature compares equal with the unibyte
 205       ;; signature string recorded in jka-compr-compression-info-list.
 206       (set-buffer-multibyte nil)
 207       (setq buffer-undo-list t)
 208       (if (stringp data)
 209           (insert data)
 210         ;; DATA is a MIME-entity object.
 211         (let ((transfer-encoding (rmail-mime-entity-transfer-encoding data))
 212               (body (rmail-mime-entity-body data)))
 213           (insert-buffer-substring mbox-buf (car body) (cdr body))
 214           (cond ((string= transfer-encoding "base64")
 215                  (ignore-errors (base64-decode-region (point-min) (point-max))))
 216                 ((string= transfer-encoding "quoted-printable")
 217                  (quoted-printable-decode-region (point-min) (point-max))))))
 218       (write-region nil nil filename nil nil nil t))))
 219
 220 (define-button-type 'rmail-mime-save 'action 'rmail-mime-save)
 221
 222 ;;; Handlers
 223
 224 (defun rmail-mime-text-handler (content-type
 225                                 content-disposition
 226                                 content-transfer-encoding)
 227   "Handle the current buffer as a plain text MIME part."
 228   (let* ((charset (cdr (assq 'charset (cdr content-type))))
 229          (coding-system (when charset
 230                           (intern (downcase charset)))))
 231     (when (coding-system-p coding-system)
 232       (decode-coding-region (point-min) (point-max) coding-system))))
 233
 234 (defun rmail-mime-insert-text (entity)
 235   "Insert MIME-entity ENTITY as a plain text MIME part in the current buffer."
 236   (let* ((content-type (rmail-mime-entity-type entity))
 237          (charset (cdr (assq 'charset (cdr content-type))))
 238          (coding-system (if charset (intern (downcase charset))))
 239          (transfer-encoding (rmail-mime-entity-transfer-encoding entity))
 240          (body (rmail-mime-entity-body entity)))
 241     (save-restriction
 242       (narrow-to-region (point) (point))
 243       (insert-buffer-substring rmail-buffer (car body) (cdr body))
 244       (cond ((string= transfer-encoding "base64")
 245              (ignore-errors (base64-decode-region (point-min) (point-max))))
 246             ((string= transfer-encoding "quoted-printable")
 247              (quoted-printable-decode-region (point-min) (point-max))))
 248       (if (coding-system-p coding-system)
 249           (decode-coding-region (point-min) (point-max) coding-system)))))
 250
 251 ;; FIXME move to the test/ directory?
 252 (defun test-rmail-mime-handler ()
 253   "Test of a mail using no MIME parts at all."
 254   (let ((mail "To: alex@gnu.org
 255 Content-Type: text/plain; charset=koi8-r
 256 Content-Transfer-Encoding: 8bit
 257 MIME-Version: 1.0
 258
 259 \372\304\322\301\327\323\324\327\325\312\324\305\41"))
 260     (switch-to-buffer (get-buffer-create "*test*"))
 261     (erase-buffer)
 262     (set-buffer-multibyte nil)
 263     (insert mail)
 264     (rmail-mime-show t)
 265     (set-buffer-multibyte t)))
 266
 267
 268 (defun rmail-mime-insert-image (type data)
 269   "Insert an image of type TYPE, where DATA is the image data.
 270 If DATA is not a string, it is a MIME-entity object."
 271   (end-of-line)
 272   (let ((modified (buffer-modified-p)))
 273     (insert ?\n)
 274     (unless (stringp data)
 275       ;; DATA is a MIME-entity.
 276       (let ((transfer-encoding (rmail-mime-entity-transfer-encoding data))
 277             (body (rmail-mime-entity-body data))
 278             (mbox-buffer rmail-view-buffer))
 279         (with-temp-buffer
 280           (set-buffer-multibyte nil)
 281           (setq buffer-undo-list t)
 282           (insert-buffer-substring mbox-buffer (car body) (cdr body))
 283           (cond ((string= transfer-encoding "base64")
 284                  (ignore-errors (base64-decode-region (point-min) (point-max))))
 285                 ((string= transfer-encoding "quoted-printable")
 286                  (quoted-printable-decode-region (point-min) (point-max))))
 287           (setq data
 288                 (buffer-substring-no-properties (point-min) (point-max))))))
 289     (insert-image (create-image data type t))
 290     (set-buffer-modified-p modified)))
 291
 292 (defun rmail-mime-image (button)
 293   "Display the image associated with BUTTON."
 294   (let ((inhibit-read-only t))
 295     (rmail-mime-insert-image (button-get button 'image-type)
 296                              (button-get button 'image-data))))
 297
 298 (define-button-type 'rmail-mime-image 'action 'rmail-mime-image)
 299
 300
 301 (defun rmail-mime-bulk-handler (content-type
 302                                 content-disposition
 303                                 content-transfer-encoding)
 304   "Handle the current buffer as an attachment to download.
 305 For images that Emacs is capable of displaying, the behavior
 306 depends upon the value of `rmail-mime-show-images'."
 307   (rmail-mime-insert-bulk
 308    (rmail-mime-entity content-type content-disposition content-transfer-encoding
 309                       nil nil nil)))
 310
 311 (defun rmail-mime-insert-bulk (entity)
 312   "Inesrt a MIME-entity ENTITY as an attachment.
 313 The optional second arg DATA, if non-nil, is a string containing
 314 the attachment data that is already decoded."
 315   ;; Find the default directory for this media type.
 316   (let* ((content-type (rmail-mime-entity-type entity))
 317          (content-disposition (rmail-mime-entity-disposition entity))
 318          (body (rmail-mime-entity-body entity))
 319          (directory (catch 'directory
 320                       (dolist (entry rmail-mime-attachment-dirs-alist)
 321                         (when (string-match (car entry) (car content-type))
 322                           (dolist (dir (cdr entry))
 323                             (when (file-directory-p dir)
 324                               (throw 'directory dir)))))))
 325          (filename (or (cdr (assq 'name (cdr content-type)))
 326                        (cdr (assq 'filename (cdr content-disposition)))
 327                        "noname"))
 328          (label (format "\nAttached %s file: " (car content-type)))
 329          (units '(B kB MB GB))
 330          data udata size osize type)
 331     (if body
 332         (setq data entity
 333               udata entity
 334               size (- (cdr body) (car body)))
 335       (setq data (buffer-string)
 336             udata (string-as-unibyte data)
 337             size (length udata))
 338       (delete-region (point-min) (point-max)))
 339     (setq osize size)
 340     (while (and (> size 1024.0) ; cribbed from gnus-agent-expire-done-message
 341                 (cdr units))
 342       (setq size (/ size 1024.0)
 343             units (cdr units)))
 344     (insert label)
 345     (insert-button filename
 346                    :type 'rmail-mime-save
 347                    'help-echo "mouse-2, RET: Save attachment"
 348                    'filename filename
 349                    'directory (file-name-as-directory directory)
 350                    'data data)
 351     (insert (format " (%.0f%s)" size (car units)))
 352     (when (and rmail-mime-show-images
 353                (string-match "image/\\(.*\\)" (setq type (car content-type)))
 354                (setq type (concat "." (match-string 1 type))
 355                      type (image-type-from-file-name type))
 356                (memq type image-types)
 357                (image-type-available-p type))
 358       (insert " ")
 359       (cond ((or (eq rmail-mime-show-images 'button)
 360                  (and (numberp rmail-mime-show-images)
 361                       (>= osize rmail-mime-show-images)))
 362              (insert-button "Display"
 363                             :type 'rmail-mime-image
 364                             'help-echo "mouse-2, RET: Show image"
 365                             'image-type type
 366                             'image-data udata))
 367             (t
 368              (rmail-mime-insert-image type udata))))))
 369
 370 (defun test-rmail-mime-bulk-handler ()
 371   "Test of a mail used as an example in RFC 2183."
 372   (let ((mail "Content-Type: image/jpeg
 373 Content-Disposition: attachment; filename=genome.jpeg;
 374   modification-date=\"Wed, 12 Feb 1997 16:29:51 -0500\";
 375 Content-Description: a complete map of the human genome
 376 Content-Transfer-Encoding: base64
 377
 378 iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAMAAABg3Am1AAAABGdBTUEAALGPC/xhBQAAAAZQ
 379 TFRF////AAAAVcLTfgAAAPZJREFUeNq9ldsOwzAIQ+3//+l1WlvA5ZLsoUiTto4TB+ISoAjy
 380 +ITfRBfcAmgRFFeAm+J6uhdKdFhFWUgDkFsK0oUp/9G2//Kj7Jx+5tSKOdBscgUYiKHRS/me
 381 WATQdRUvAK0Bnmshmtn79PpaLBbbOZkjKvRnjRZoRswOkG1wFchKew2g9wXVJVZL/m4+B+vv
 382 9AxQQR2Q33SgAYJzzVACdAWjAfRYzYFO9n6SLnydtQHSMxYDMAKqZ/8FS/lTK+zuq3CtK64L
 383 UDwbgUEAUmk2Zyg101d6PhCDySgAvTvDgKiuOrc4dLxUb7UMnhGIexyI+d6U+ABuNAP4Simx
 384 lgAAAABJRU5ErkJggg==
 385 "))
 386     (switch-to-buffer (get-buffer-create "*test*"))
 387     (erase-buffer)
 388     (insert mail)
 389     (rmail-mime-show)))
 390
 391 (defun rmail-mime-multipart-handler (content-type
 392                                      content-disposition
 393                                      content-transfer-encoding)
 394   "Handle the current buffer as a multipart MIME body.
 395 The current buffer should be narrowed to the body.  CONTENT-TYPE,
 396 CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values
 397 of the respective parsed headers.  See `rmail-mime-handle' for their
 398 format."
 399   (rmail-mime-process-multipart
 400    content-type content-disposition content-transfer-encoding nil))
 401
 402 (defun rmail-mime-process-multipart (content-type
 403                                      content-disposition
 404                                      content-transfer-encoding
 405                                      parse-only)
 406   "Process the current buffer as a multipart MIME body.
 407
 408 If PARSE-ONLY is nil, modify the current buffer directly for showing
 409 the MIME body and return nil.
 410
 411 Otherwise, just parse the current buffer and return a list of
 412 MIME-entity objects.
 413
 414 The other arguments are the same as `rmail-mime-multipart-handler'."
 415   ;; Some MUAs start boundaries with "--", while it should start
 416   ;; with "CRLF--", as defined by RFC 2046:
 417   ;;    The boundary delimiter MUST occur at the beginning of a line,
 418   ;;    i.e., following a CRLF, and the initial CRLF is considered to
 419   ;;    be attached to the boundary delimiter line rather than part
 420   ;;    of the preceding part.
 421   ;; We currently don't handle that.
 422   (let ((boundary (cdr (assq 'boundary content-type)))
 423         beg end next entities)
 424     (unless boundary
 425       (rmail-mm-get-boundary-error-message
 426        "No boundary defined" content-type content-disposition
 427        content-transfer-encoding))
 428     (setq boundary (concat "\n--" boundary))
 429     ;; Hide the body before the first bodypart
 430     (goto-char (point-min))
 431     (when (and (search-forward boundary nil t)
 432                (looking-at "[ \t]*\n"))
 433       (if parse-only
 434           (narrow-to-region (match-end 0) (point-max))
 435         (delete-region (point-min) (match-end 0))))
 436     ;; Loop over all body parts, where beg points at the beginning of
 437     ;; the part and end points at the end of the part.  next points at
 438     ;; the beginning of the next part.
 439     (setq beg (point-min))
 440     (while (search-forward boundary nil t)
 441       (setq end (match-beginning 0))
 442       ;; If this is the last boundary according to RFC 2046, hide the
 443       ;; epilogue, else hide the boundary only.  Use a marker for
 444       ;; `next' because `rmail-mime-show' may change the buffer.
 445       (cond ((looking-at "--[ \t]*$")
 446              (setq next (point-max-marker)))
 447             ((looking-at "[ \t]*\n")
 448              (setq next (copy-marker (match-end 0) t)))
 449             (t
 450              (rmail-mm-get-boundary-error-message
 451               "Malformed boundary" content-type content-disposition
 452               content-transfer-encoding)))
 453       ;; Handle the part.
 454       (if parse-only
 455           (save-restriction
 456             (narrow-to-region beg end)
 457             (setq entities (cons (rmail-mime-process nil t) entities)))
 458         (delete-region end next)
 459         (save-restriction
 460           (narrow-to-region beg end)
 461           (rmail-mime-show)))
 462       (goto-char (setq beg next)))
 463     (nreverse entities)))
 464
 465 (defun test-rmail-mime-multipart-handler ()
 466   "Test of a mail used as an example in RFC 2046."
 467   (let ((mail "From: Nathaniel Borenstein <nsb@bellcore.com>
 468 To: Ned Freed <ned@innosoft.com>
 469 Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST)
 470 Subject: Sample message
 471 MIME-Version: 1.0
 472 Content-type: multipart/mixed; boundary=\"simple boundary\"
 473
 474 This is the preamble.  It is to be ignored, though it
 475 is a handy place for composition agents to include an
 476 explanatory note to non-MIME conformant readers.
 477
 478 --simple boundary
 479
 480 This is implicitly typed plain US-ASCII text.
 481 It does NOT end with a linebreak.
 482 --simple boundary
 483 Content-type: text/plain; charset=us-ascii
 484
 485 This is explicitly typed plain US-ASCII text.
 486 It DOES end with a linebreak.
 487
 488 --simple boundary--
 489
 490 This is the epilogue.  It is also to be ignored."))
 491     (switch-to-buffer (get-buffer-create "*test*"))
 492     (erase-buffer)
 493     (insert mail)
 494     (rmail-mime-show t)))
 495
 496 ;;; Main code
 497
 498 (defun rmail-mime-handle (content-type
 499                           content-disposition
 500                           content-transfer-encoding)
 501   "Handle the current buffer as a MIME part.
 502 The current buffer should be narrowed to the respective body, and
 503 point should be at the beginning of the body.
 504
 505 CONTENT-TYPE, CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING
 506 are the values of the respective parsed headers.  The latter should
 507 be downcased.  The parsed headers for CONTENT-TYPE and CONTENT-DISPOSITION
 508 have the form
 509
 510   \(VALUE . ALIST)
 511
 512 In other words:
 513
 514   \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)
 515
 516 VALUE is a string and ATTRIBUTE is a symbol.
 517
 518 Consider the following header, for example:
 519
 520 Content-Type: multipart/mixed;
 521         boundary=\"----=_NextPart_000_0104_01C617E4.BDEC4C40\"
 522
 523 The parsed header value:
 524
 525 \(\"multipart/mixed\"
 526   \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))"
 527   ;; Handle the content transfer encodings we know.  Unknown transfer
 528   ;; encodings will be passed on to the various handlers.
 529   (cond ((string= content-transfer-encoding "base64")
 530          (when (ignore-errors
 531                  (base64-decode-region (point) (point-max)))
 532            (setq content-transfer-encoding nil)))
 533         ((string= content-transfer-encoding "quoted-printable")
 534          (quoted-printable-decode-region (point) (point-max))
 535          (setq content-transfer-encoding nil))
 536         ((string= content-transfer-encoding "8bit")
 537          ;; FIXME: Is this the correct way?
 538          ;; No, of course not, it just means there's no decoding to do.
 539          ;; (set-buffer-multibyte nil)
 540          (setq content-transfer-encoding nil)
 541          ))
 542   ;; Inline stuff requires work.  Attachments are handled by the bulk
 543   ;; handler.
 544   (if (string= "inline" (car content-disposition))
 545       (let ((stop nil))
 546         (dolist (entry rmail-mime-media-type-handlers-alist)
 547           (when (and (string-match (car entry) (car content-type)) (not stop))
 548             (progn
 549               (setq stop (funcall (cadr entry) content-type
 550                                   content-disposition
 551                                   content-transfer-encoding))))))
 552     ;; Everything else is an attachment.
 553     (rmail-mime-bulk-handler content-type
 554                        content-disposition
 555                        content-transfer-encoding)))
 556
 557 (defun rmail-mime-show (&optional show-headers)
 558   "Handle the current buffer as a MIME message.
 559 If SHOW-HEADERS is non-nil, then the headers of the current part
 560 will shown as usual for a MIME message.  The headers are also
 561 shown for the content type message/rfc822.  This function will be
 562 called recursively if multiple parts are available.
 563
 564 The current buffer must contain a single message.  It will be
 565 modified."
 566   (rmail-mime-process show-headers nil))
 567
 568 (defun rmail-mime-process (show-headers parse-only)
 569   (let ((end (point-min))
 570         content-type
 571         content-transfer-encoding
 572         content-disposition)
 573     ;; `point-min' returns the beginning and `end' points at the end
 574     ;; of the headers.
 575     (goto-char (point-min))
 576     ;; If we're showing a part without headers, then it will start
 577     ;; with a newline.
 578     (if (eq (char-after) ?\n)
 579         (setq end (1+ (point)))
 580       (when (search-forward "\n\n" nil t)
 581         (setq end (match-end 0))
 582         (save-restriction
 583           (narrow-to-region (point-min) end)
 584           ;; FIXME: Default disposition of the multipart entities should
 585           ;; be inherited.
 586           (setq content-type
 587                 (mail-fetch-field "Content-Type")
 588                 content-transfer-encoding
 589                 (mail-fetch-field "Content-Transfer-Encoding")
 590                 content-disposition
 591                 (mail-fetch-field "Content-Disposition")))))
 592     ;; Per RFC 2045, C-T-E is case insensitive (bug#5070), but the others
 593     ;; are not completely so.  Hopefully mail-header-parse-* DTRT.
 594     (if content-transfer-encoding
 595         (setq content-transfer-encoding (downcase content-transfer-encoding)))
 596     (setq content-type
 597           (if content-type
 598               (mail-header-parse-content-type content-type)
 599             ;; FIXME: Default "message/rfc822" in a "multipart/digest"
 600             ;; according to RFC 2046.
 601             '("text/plain")))
 602     (setq content-disposition
 603           (if content-disposition
 604               (mail-header-parse-content-disposition content-disposition)
 605             ;; If none specified, we are free to choose what we deem
 606             ;; suitable according to RFC 2183.  We like inline.
 607             '("inline")))
 608     ;; Unrecognized disposition types are to be treated like
 609     ;; attachment according to RFC 2183.
 610     (unless (member (car content-disposition) '("inline" "attachment"))
 611       (setq content-disposition '("attachment")))
 612
 613     (if parse-only
 614         (cond ((string-match "multipart/.*" (car content-type))
 615                (setq end (1- end))
 616                (save-restriction
 617                  (let ((header (if show-headers (cons (point-min) end))))
 618                    (narrow-to-region end (point-max))
 619                    (rmail-mime-entity content-type
 620                                       content-disposition
 621                                       content-transfer-encoding
 622                                       header nil
 623                                       (rmail-mime-process-multipart
 624                                        content-type content-disposition
 625                                        content-transfer-encoding t)))))
 626               ((string-match "message/rfc822" (car content-type))
 627                (or show-headers
 628                    (narrow-to-region end (point-max)))
 629                (rmail-mime-process t t))
 630               (t
 631                (rmail-mime-entity content-type
 632                                   content-disposition
 633                                   content-transfer-encoding
 634                                   nil
 635                                   (cons end (point-max))
 636                                   nil)))
 637       ;; Hide headers and handle the part.
 638       (save-restriction
 639         (cond ((string= (car content-type) "message/rfc822")
 640                (narrow-to-region end (point-max)))
 641               ((not show-headers)
 642                (delete-region (point-min) end)))
 643         (rmail-mime-handle content-type content-disposition
 644                            content-transfer-encoding)))))
 645
 646 (defun rmail-mime-insert-multipart (entity)
 647   "Insert MIME-entity ENTITY of multipart type in the current buffer."
 648   (let ((subtype (cadr (split-string (car (rmail-mime-entity-type entity))
 649                                      "/")))
 650         (disposition (rmail-mime-entity-disposition entity))
 651         (header (rmail-mime-entity-header entity))
 652         (children (rmail-mime-entity-children entity)))
 653     (if header
 654         (let ((pos (point)))
 655           (or (bolp)
 656               (insert "\n"))
 657           (insert-buffer-substring rmail-buffer (car header) (cdr header))
 658           (rfc2047-decode-region pos (point))
 659           (insert "\n")))
 660     (cond
 661      ((string= subtype "mixed")
 662       (dolist (child children)
 663         (rmail-mime-insert child '("text/plain") disposition)))
 664      ((string= subtype "digest")
 665       (dolist (child children)
 666         (rmail-mime-insert child '("message/rfc822") disposition)))
 667      ((string= subtype "alternative")
 668       (let (best-plain-text best-text)
 669         (dolist (child children)
 670           (if (string= (or (car (rmail-mime-entity-disposition child))
 671                            (car disposition))
 672                        "inline")
 673               (if (string-match "text/plain"
 674                                 (car (rmail-mime-entity-type child)))
 675                   (setq best-plain-text child)
 676                 (if (string-match "text/.*"
 677                                   (car (rmail-mime-entity-type child)))
 678                     (setq best-text child)))))
 679         (if (or best-plain-text best-text)
 680             (rmail-mime-insert (or best-plain-text best-text))
 681           ;; No child could be handled.  Insert all.
 682           (dolist (child children)
 683             (rmail-mime-insert child nil disposition)))))
 684      (t
 685       ;; Unsupported subtype.  Insert all of them.
 686       (dolist (child children)
 687         (rmail-mime-insert child))))))
 688
 689 (defun rmail-mime-parse ()
 690   "Parse the current Rmail message as a MIME message.
 691 The value is a MIME-entiy object (see `rmail-mime-enty-new')."
 692   (save-excursion
 693     (goto-char (point-min))
 694     (condition-case nil
 695         (rmail-mime-process nil t)
 696       (error nil))))
 697
 698 (defun rmail-mime-insert (entity &optional content-type disposition)
 699   "Insert a MIME-entity ENTITY in the current buffer.
 700
 701 This function will be called recursively if multiple parts are
 702 available."
 703   (if (rmail-mime-entity-children entity)
 704       (rmail-mime-insert-multipart entity)
 705     (setq content-type
 706           (or (rmail-mime-entity-type entity) content-type))
 707     (setq disposition
 708           (or (rmail-mime-entity-disposition entity) disposition))
 709     (if (and (string= (car disposition) "inline")
 710              (string-match "text/.*" (car content-type)))
 711         (rmail-mime-insert-text entity)
 712       (rmail-mime-insert-bulk entity))))
 713
 714 (define-derived-mode rmail-mime-mode fundamental-mode "RMIME"
 715   "Major mode used in `rmail-mime' buffers."
 716   (setq font-lock-defaults '(rmail-font-lock-keywords t t nil nil)))
 717
 718 ;;;###autoload
 719 (defun rmail-mime ()
 720   "Process the current Rmail message as a MIME message.
 721 This creates a temporary \"*RMAIL*\" buffer holding a decoded
 722 copy of the message.  Inline content-types are handled according to
 723 `rmail-mime-media-type-handlers-alist'.  By default, this
 724 displays text and multipart messages, and offers to download
 725 attachments as specfied by `rmail-mime-attachment-dirs-alist'."
 726   (interactive)
 727   (let ((data (rmail-apply-in-message rmail-current-message 'buffer-string))
 728         (buf (get-buffer-create "*RMAIL*")))
 729     (set-buffer buf)
 730     (setq buffer-undo-list t)
 731     (let ((inhibit-read-only t))
 732       ;; Decoding the message in fundamental mode for speed, only
 733       ;; switching to rmail-mime-mode at the end for display.  Eg
 734       ;; quoted-printable-decode-region gets very slow otherwise (Bug#4993).
 735       (fundamental-mode)
 736       (erase-buffer)
 737       (insert data)
 738       (rmail-mime-show t)
 739       (rmail-mime-mode)
 740       (set-buffer-modified-p nil))
 741     (view-buffer buf)))
 742
 743 (defun rmail-mm-get-boundary-error-message (message type disposition encoding)
 744   "Return MESSAGE with more information on the main mime components."
 745   (error "%s; type: %s; disposition: %s; encoding: %s"
 746          message type disposition encoding))
 747
 748 (defun rmail-show-mime ()
 749   "Function to set in `rmail-show-mime-function' (which see)."
 750   (let ((mbox-buf rmail-buffer)
 751         (entity (rmail-mime-parse)))
 752     (if entity
 753         (with-current-buffer rmail-view-buffer
 754           (let ((inhibit-read-only t)
 755                 (rmail-buffer mbox-buf))
 756             (erase-buffer)
 757             (rmail-mime-insert entity)))
 758       ;; Decoding failed.  Insert the original message body as is.
 759       (let ((region (with-current-buffer mbox-buf
 760                       (goto-char (point-min))
 761                       (re-search-forward "^$" nil t)
 762                       (forward-line 1)
 763                       (cons (point) (point-max)))))
 764         (with-current-buffer rmail-view-buffer
 765           (let ((inhibit-read-only t))
 766             (erase-buffer)
 767             (insert-buffer-substring mbox-buf (car region) (cdr region))))
 768         (message "MIME decoding failed")))))
 769
 770 (setq rmail-show-mime-function 'rmail-show-mime)
 771
 772 (defun rmail-insert-mime-forwarded-message (forward-buffer)
 773   "Function to set in `rmail-insert-mime-forwarded-message-function' (which see)."
 774   (let ((mbox-buf (with-current-buffer forward-buffer rmail-view-buffer)))
 775     (save-restriction
 776       (narrow-to-region (point) (point))
 777       (message-forward-make-body-mime mbox-buf))))
 778
 779 (setq rmail-insert-mime-forwarded-message-function
 780       'rmail-insert-mime-forwarded-message)
 781
 782 (defun rmail-insert-mime-resent-message (forward-buffer)
 783   "Function to set in `rmail-insert-mime-resent-message-function' (which see)."
 784   (insert-buffer-substring
 785    (with-current-buffer forward-buffer rmail-view-buffer))
 786   (goto-char (point-min))
 787   (when (looking-at "From ")
 788     (forward-line 1)
 789     (delete-region (point-min) (point))))
 790
 791 (setq rmail-insert-mime-resent-message-function
 792       'rmail-insert-mime-resent-message)
 793
 794 (defun rmail-search-mime-message (msg regexp)
 795   "Function to set in `rmail-search-mime-message-function' (which see)."
 796   (save-restriction
 797     (narrow-to-region (rmail-msgbeg msg) (rmail-msgend msg))
 798     (let ((mbox-buf (current-buffer))
 799           (header-end (save-excursion
 800                         (re-search-forward "^$" nil 'move) (point)))
 801           (body-end (point-max))
 802           (entity (rmail-mime-parse)))
 803       (or
 804        ;; At first, just search the headers.
 805        (with-temp-buffer
 806          (insert-buffer-substring mbox-buf nil header-end)
 807          (rfc2047-decode-region (point-min) (point))
 808          (goto-char (point-min))
 809          (re-search-forward regexp nil t))
 810        ;; Next, search the body.
 811        (if (and entity
 812                 (let* ((content-type (rmail-mime-entity-type entity))
 813                        (charset (cdr (assq 'charset (cdr content-type)))))
 814                   (or (not (string-match "text/.*" (car content-type)))
 815                       (and charset
 816                            (not (string= (downcase charset) "us-ascii"))))))
 817            ;; Search the decoded MIME message.
 818            (with-temp-buffer
 819              (let ((rmail-buffer mbox-buf))
 820                (rmail-mime-insert entity))
 821              (goto-char (point-min))
 822              (re-search-forward regexp nil t))
 823          ;; Search the body without decoding.
 824          (goto-char header-end)
 825          (re-search-forward regexp nil t))))))
 826
 827 (setq rmail-search-mime-message-function 'rmail-search-mime-message)
 828
 829 (provide 'rmailmm)
 830
 831 ;; Local Variables:
 832 ;; generated-autoload-file: "rmail.el"
 833 ;; End:
 834
 835 ;; arch-tag: 3f2c5e5d-1aef-4512-bc20-fd737c9d5dd9
 836 ;;; rmailmm.el ends here