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

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