cgit.sxemacs.org Git - gnus/blob - lisp/mm-decode.el

   1 ;;; mm-decode.el --- Functions for decoding MIME things
   2
   3 ;; Copyright (C) 1998-2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 ;; For Emacs <22.2 and XEmacs.
  27 (eval-and-compile
  28   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  29
  30 (require 'mail-parse)
  31 (require 'mm-bodies)
  32 (eval-when-compile (require 'cl)
  33                    (require 'term))
  34
  35 (autoload 'gnus-map-function "gnus-util")
  36 (autoload 'gnus-replace-in-string "gnus-util")
  37 (autoload 'gnus-read-shell-command "gnus-util")
  38
  39 (autoload 'mm-inline-partial "mm-partial")
  40 (autoload 'mm-inline-external-body "mm-extern")
  41 (autoload 'mm-extern-cache-contents "mm-extern")
  42 (autoload 'mm-insert-inline "mm-view")
  43
  44 (autoload 'mm-archive-decoders "mm-archive")
  45 (autoload 'mm-archive-dissect-and-inline "mm-archive")
  46 (autoload 'mm-dissect-archive "mm-archive")
  47
  48 (defvar gnus-current-window-configuration)
  49
  50 (add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list)
  51
  52 (defgroup mime-display ()
  53   "Display of MIME in mail and news articles."
  54   :link '(custom-manual "(emacs-mime)Display Customization")
  55   :version "21.1"
  56   :group 'mail
  57   :group 'news
  58   :group 'multimedia)
  59
  60 (defgroup mime-security ()
  61   "MIME security in mail and news articles."
  62   :link '(custom-manual "(emacs-mime)Display Customization")
  63   :group 'mail
  64   :group 'news
  65   :group 'multimedia)
  66
  67 ;;; Convenience macros.
  68
  69 (defmacro mm-handle-buffer (handle)
  70   `(nth 0 ,handle))
  71 (defmacro mm-handle-type (handle)
  72   `(nth 1 ,handle))
  73 (defsubst mm-handle-media-type (handle)
  74   (if (stringp (car handle))
  75       (car handle)
  76     (car (mm-handle-type handle))))
  77 (defsubst mm-handle-media-supertype (handle)
  78   (car (split-string (mm-handle-media-type handle) "/")))
  79 (defsubst mm-handle-media-subtype (handle)
  80   (cadr (split-string (mm-handle-media-type handle) "/")))
  81 (defmacro mm-handle-encoding (handle)
  82   `(nth 2 ,handle))
  83 (defmacro mm-handle-undisplayer (handle)
  84   `(nth 3 ,handle))
  85 (defmacro mm-handle-set-undisplayer (handle function)
  86   `(setcar (nthcdr 3 ,handle) ,function))
  87 (defmacro mm-handle-disposition (handle)
  88   `(nth 4 ,handle))
  89 (defmacro mm-handle-description (handle)
  90   `(nth 5 ,handle))
  91 (defmacro mm-handle-cache (handle)
  92   `(nth 6 ,handle))
  93 (defmacro mm-handle-set-cache (handle contents)
  94   `(setcar (nthcdr 6 ,handle) ,contents))
  95 (defmacro mm-handle-id (handle)
  96   `(nth 7 ,handle))
  97 (defmacro mm-handle-multipart-original-buffer (handle)
  98   `(get-text-property 0 'buffer (car ,handle)))
  99 (defmacro mm-handle-multipart-from (handle)
 100   `(get-text-property 0 'from (car ,handle)))
 101 (defmacro mm-handle-multipart-ctl-parameter (handle parameter)
 102   `(get-text-property 0 ,parameter (car ,handle)))
 103
 104 (defmacro mm-make-handle (&optional buffer type encoding undisplayer
 105                                     disposition description cache
 106                                     id)
 107   `(list ,buffer ,type ,encoding ,undisplayer
 108          ,disposition ,description ,cache ,id))
 109
 110 (defcustom mm-text-html-renderer
 111   (cond ((fboundp 'libxml-parse-html-region) 'shr)
 112         ((executable-find "w3m") 'gnus-w3m)
 113         ((executable-find "links") 'links)
 114         ((executable-find "lynx") 'lynx)
 115         ((locate-library "w3") 'w3)
 116         ((locate-library "html2text") 'html2text)
 117         (t nil))
 118   "Render of HTML contents.
 119 It is one of defined renderer types, or a rendering function.
 120 The defined renderer types are:
 121 `shr': use the built-in Gnus HTML renderer;
 122 `gnus-w3m': use Gnus renderer based on w3m;
 123 `w3m': use emacs-w3m;
 124 `w3m-standalone': use plain w3m;
 125 `links': use links;
 126 `lynx': use lynx;
 127 `w3': use Emacs/W3;
 128 `html2text': use html2text;
 129 nil    : use external viewer (default web browser)."
 130   :version "24.1"
 131   :type '(choice (const shr)
 132                  (const gnus-w3m)
 133                  (const w3)
 134                  (const w3m :tag "emacs-w3m")
 135                  (const w3m-standalone :tag "standalone w3m" )
 136                  (const links)
 137                  (const lynx)
 138                  (const html2text)
 139                  (const nil :tag "External viewer")
 140                  (function))
 141   :group 'mime-display)
 142
 143 (defcustom mm-inline-text-html-with-images nil
 144   "If non-nil, Gnus will allow retrieving images in HTML contents with
 145 the <img> tags.  It has no effect on Emacs/w3.  See also the
 146 documentation for the `mm-w3m-safe-url-regexp' variable."
 147   :version "22.1"
 148   :type 'boolean
 149   :group 'mime-display)
 150
 151 (defcustom mm-w3m-safe-url-regexp "\\`cid:"
 152   "Regexp matching URLs which are considered to be safe.
 153 Some HTML mails might contain a nasty trick used by spammers, using
 154 the <img> tag which is far more evil than the [Click Here!] button.
 155 It is most likely intended to check whether the ominous spam mail has
 156 reached your eyes or not, in which case the spammer knows for sure
 157 that your email address is valid.  It is done by embedding an
 158 identifier string into a URL that you might automatically retrieve
 159 when displaying the image.  The default value is \"\\\\`cid:\" which only
 160 matches parts embedded to the Multipart/Related type MIME contents and
 161 Gnus will never connect to the spammer's site arbitrarily.  You may
 162 set this variable to nil if you consider all urls to be safe."
 163   :version "22.1"
 164   :type '(choice (regexp :tag "Regexp")
 165                  (const :tag "All URLs are safe" nil))
 166   :group 'mime-display)
 167
 168 (defcustom mm-inline-text-html-with-w3m-keymap t
 169   "If non-nil, use emacs-w3m command keys in the article buffer."
 170   :version "22.1"
 171   :type 'boolean
 172   :group 'mime-display)
 173
 174 (defcustom mm-enable-external t
 175   "Indicate whether external MIME handlers should be used.
 176
 177 If t, all defined external MIME handlers are used.  If nil, files are saved by
 178 `mailcap-save-binary-file'.  If it is the symbol `ask', you are prompted
 179 before the external MIME handler is invoked."
 180   :version "22.1"
 181   :type '(choice (const :tag "Always" t)
 182                  (const :tag "Never" nil)
 183                  (const :tag "Ask" ask))
 184   :group 'mime-display)
 185
 186 (defcustom mm-inline-media-tests
 187   '(("image/p?jpeg"
 188      mm-inline-image
 189      (lambda (handle)
 190        (mm-valid-and-fit-image-p 'jpeg handle)))
 191     ("image/png"
 192      mm-inline-image
 193      (lambda (handle)
 194        (mm-valid-and-fit-image-p 'png handle)))
 195     ("image/gif"
 196      mm-inline-image
 197      (lambda (handle)
 198        (mm-valid-and-fit-image-p 'gif handle)))
 199     ("image/tiff"
 200      mm-inline-image
 201      (lambda (handle)
 202        (mm-valid-and-fit-image-p 'tiff handle)))
 203     ("image/xbm"
 204      mm-inline-image
 205      (lambda (handle)
 206        (mm-valid-and-fit-image-p 'xbm handle)))
 207     ("image/x-xbitmap"
 208      mm-inline-image
 209      (lambda (handle)
 210        (mm-valid-and-fit-image-p 'xbm handle)))
 211     ("image/xpm"
 212      mm-inline-image
 213      (lambda (handle)
 214        (mm-valid-and-fit-image-p 'xpm handle)))
 215     ("image/x-xpixmap"
 216      mm-inline-image
 217      (lambda (handle)
 218        (mm-valid-and-fit-image-p 'xpm handle)))
 219     ("image/bmp"
 220      mm-inline-image
 221      (lambda (handle)
 222        (mm-valid-and-fit-image-p 'bmp handle)))
 223     ("image/x-portable-bitmap"
 224      mm-inline-image
 225      (lambda (handle)
 226        (mm-valid-and-fit-image-p 'pbm handle)))
 227     ("text/plain" mm-inline-text identity)
 228     ("text/enriched" mm-inline-text identity)
 229     ("text/richtext" mm-inline-text identity)
 230     ("text/x-patch" mm-display-patch-inline identity)
 231     ;; In case mime.types uses x-diff (as does Debian's mime-support-3.40).
 232     ("text/x-diff" mm-display-patch-inline identity)
 233     ("application/emacs-lisp" mm-display-elisp-inline identity)
 234     ("application/x-emacs-lisp" mm-display-elisp-inline identity)
 235     ("application/x-shellscript" mm-display-shell-script-inline identity)
 236     ("application/x-sh" mm-display-shell-script-inline identity)
 237     ("text/x-sh" mm-display-shell-script-inline identity)
 238     ("application/javascript" mm-display-javascript-inline identity)
 239     ("text/dns" mm-display-dns-inline identity)
 240     ("text/x-org" mm-display-org-inline identity)
 241     ("text/html"
 242      mm-inline-text-html
 243      (lambda (handle)
 244        mm-text-html-renderer))
 245     ("text/x-vcard"
 246      mm-inline-text-vcard
 247      (lambda (handle)
 248        (or (featurep 'vcard)
 249            (locate-library "vcard"))))
 250     ("message/delivery-status" mm-inline-text identity)
 251     ("message/rfc822" mm-inline-message identity)
 252     ("message/partial" mm-inline-partial identity)
 253     ("message/external-body" mm-inline-external-body identity)
 254     ("text/.*" mm-inline-text identity)
 255     ("application/x-.?tar\\(-.*\\)?" mm-archive-dissect-and-inline identity)
 256     ("application/zip" mm-archive-dissect-and-inline identity)
 257     ("audio/wav" mm-inline-audio
 258      (lambda (handle)
 259        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 260             (device-sound-enabled-p))))
 261     ("audio/au"
 262      mm-inline-audio
 263      (lambda (handle)
 264        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 265             (device-sound-enabled-p))))
 266     ("application/pgp-signature" ignore identity)
 267     ("application/x-pkcs7-signature" ignore identity)
 268     ("application/pkcs7-signature" ignore identity)
 269     ("application/x-pkcs7-mime" ignore identity)
 270     ("application/pkcs7-mime" ignore identity)
 271     ("multipart/alternative" ignore identity)
 272     ("multipart/mixed" ignore identity)
 273     ("multipart/related" ignore identity)
 274     ("image/.*"
 275      mm-inline-image
 276      (lambda (handle)
 277        (and (mm-valid-image-format-p 'imagemagick)
 278             (mm-with-unibyte-buffer
 279               (mm-insert-part handle)
 280               (let ((image
 281                      (ignore-errors
 282                        (if (fboundp 'create-image)
 283                            (create-image (buffer-string) 'imagemagick 'data-p)
 284                          (mm-create-image-xemacs
 285                           (mm-handle-media-subtype handle))))))
 286                 (when image
 287                   (setcar (cdr handle) (list "image/imagemagick"))
 288                   (mm-image-fit-p handle)))))))
 289     ;; Disable audio and image
 290     ("audio/.*" ignore ignore)
 291     ("image/.*" ignore ignore)
 292     ;; Default to displaying as text
 293     (".*" mm-inline-text mm-readable-p))
 294   "Alist of media types/tests saying whether types can be displayed inline."
 295   :type '(repeat (list (regexp :tag "MIME type")
 296                        (function :tag "Display function")
 297                        (function :tag "Display test")))
 298   :group 'mime-display)
 299
 300 (defcustom mm-inlined-types
 301   '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
 302     "message/partial" "message/external-body" "application/emacs-lisp"
 303     "application/x-emacs-lisp"
 304     "application/pgp-signature" "application/x-pkcs7-signature"
 305     "application/pkcs7-signature" "application/x-pkcs7-mime"
 306     "application/pkcs7-mime"
 307     "application/x-gtar-compressed"
 308     "application/x-tar"
 309     "application/zip"
 310     ;; Mutt still uses this even though it has already been withdrawn.
 311     "application/pgp")
 312   "List of media types that are to be displayed inline.
 313 See also `mm-inline-media-tests', which says how to display a media
 314 type inline."
 315   :type '(repeat regexp)
 316   :group 'mime-display)
 317
 318 (defcustom mm-keep-viewer-alive-types
 319   '("application/postscript" "application/msword" "application/vnd.ms-excel"
 320     "application/pdf" "application/x-dvi")
 321   "List of media types for which the external viewer will not be killed
 322 when selecting a different article."
 323   :version "22.1"
 324   :type '(repeat regexp)
 325   :group 'mime-display)
 326
 327 (defcustom mm-automatic-display
 328   '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-verbatim"
 329     "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
 330     "message/rfc822" "text/x-patch" "text/dns" "application/pgp-signature"
 331     "application/emacs-lisp" "application/x-emacs-lisp"
 332     "application/x-pkcs7-signature"
 333     "application/pkcs7-signature" "application/x-pkcs7-mime"
 334     "application/pkcs7-mime"
 335     ;; Mutt still uses this even though it has already been withdrawn.
 336     "application/pgp\\'"
 337      "text/x-org")
 338   "A list of MIME types to be displayed automatically."
 339   :type '(repeat regexp)
 340   :group 'mime-display)
 341
 342 (defcustom mm-attachment-override-types '("text/x-vcard"
 343                                           "application/pkcs7-mime"
 344                                           "application/x-pkcs7-mime"
 345                                           "application/pkcs7-signature"
 346                                           "application/x-pkcs7-signature")
 347   "Types to have \"attachment\" ignored if they can be displayed inline."
 348   :type '(repeat regexp)
 349   :group 'mime-display)
 350
 351 (defcustom mm-inline-override-types nil
 352   "Types to be treated as attachments even if they can be displayed inline."
 353   :type '(repeat regexp)
 354   :group 'mime-display)
 355
 356 (defcustom mm-automatic-external-display nil
 357   "List of MIME type regexps that will be displayed externally automatically."
 358   :type '(repeat regexp)
 359   :group 'mime-display)
 360
 361 (defcustom mm-discouraged-alternatives nil
 362   "List of MIME types that are discouraged when viewing multipart/alternative.
 363 Viewing agents are supposed to view the last possible part of a message,
 364 as that is supposed to be the richest.  However, users may prefer other
 365 types instead, and this list says what types are most unwanted.  If,
 366 for instance, text/html parts are very unwanted, and text/richtext are
 367 somewhat unwanted, then the value of this variable should be set
 368 to:
 369
 370  (\"text/html\" \"text/richtext\")
 371
 372 Adding \"image/.*\" might also be useful.  Spammers use it as the
 373 preferred part of multipart/alternative messages.  See also
 374 `gnus-buttonized-mime-types', to which adding \"multipart/alternative\"
 375 enables you to choose manually one of two types those mails include."
 376   :type '(repeat regexp) ;; See `mm-preferred-alternative-precedence'.
 377   :group 'mime-display)
 378
 379 (defcustom mm-tmp-directory
 380   (if (fboundp 'temp-directory)
 381       (temp-directory)
 382     (if (boundp 'temporary-file-directory)
 383         temporary-file-directory
 384       "/tmp/"))
 385   "Where mm will store its temporary files."
 386   :type 'directory
 387   :group 'mime-display)
 388
 389 (defcustom mm-inline-large-images nil
 390   "If t, then all images fit in the buffer.
 391 If 'resize, try to resize the images so they fit."
 392   :type '(radio
 393           (const :tag "Inline large images as they are." t)
 394           (const :tag "Resize large images." resize)
 395           (const :tag "Do not inline large images." nil))
 396   :group 'mime-display)
 397
 398 (defcustom mm-file-name-rewrite-functions
 399   '(mm-file-name-delete-control mm-file-name-delete-gotchas)
 400   "List of functions used for rewriting file names of MIME parts.
 401 Each function takes a file name as input and returns a file name.
 402
 403 Ready-made functions include `mm-file-name-delete-control',
 404 `mm-file-name-delete-gotchas' (you should not remove these two
 405 functions), `mm-file-name-delete-whitespace',
 406 `mm-file-name-trim-whitespace', `mm-file-name-collapse-whitespace',
 407 `mm-file-name-replace-whitespace', `capitalize', `downcase',
 408 `upcase', and `upcase-initials'."
 409   :type '(list (set :inline t
 410                     (const mm-file-name-delete-control)
 411                     (const mm-file-name-delete-gotchas)
 412                     (const mm-file-name-delete-whitespace)
 413                     (const mm-file-name-trim-whitespace)
 414                     (const mm-file-name-collapse-whitespace)
 415                     (const mm-file-name-replace-whitespace)
 416                     (const capitalize)
 417                     (const downcase)
 418                     (const upcase)
 419                     (const upcase-initials)
 420                (repeat :inline t
 421                        :tag "Function"
 422                        function)))
 423   :version "23.1" ;; No Gnus
 424   :group 'mime-display)
 425
 426
 427 (defvar mm-path-name-rewrite-functions nil
 428   "*List of functions for rewriting the full file names of MIME parts.
 429 This is used when viewing parts externally, and is meant for
 430 transforming the absolute name so that non-compliant programs can find
 431 the file where it's saved.
 432
 433 Each function takes a file name as input and returns a file name.")
 434
 435 (defvar mm-file-name-replace-whitespace nil
 436   "String used for replacing whitespace characters; default is `\"_\"'.")
 437
 438 (defcustom mm-default-directory nil
 439   "The default directory where mm will save files.
 440 If not set, `default-directory' will be used."
 441   :type '(choice directory (const :tag "Default" nil))
 442   :group 'mime-display)
 443
 444 (defcustom mm-attachment-file-modes 384
 445   "Set the mode bits of saved attachments to this integer."
 446   :version "22.1"
 447   :type 'integer
 448   :group 'mime-display)
 449
 450 (defcustom mm-external-terminal-program "xterm"
 451   "The program to start an external terminal."
 452   :version "22.1"
 453   :type 'string
 454   :group 'mime-display)
 455
 456 ;;; Internal variables.
 457
 458 (defvar mm-last-shell-command "")
 459 (defvar mm-content-id-alist nil)
 460 (defvar mm-postponed-undisplay-list nil)
 461 (defvar mm-inhibit-auto-detect-attachment nil)
 462
 463 ;; According to RFC2046, in particular, in a digest, the default
 464 ;; Content-Type value for a body part is changed from "text/plain" to
 465 ;; "message/rfc822".
 466 (defvar mm-dissect-default-type "text/plain")
 467
 468 (autoload 'mml2015-verify "mml2015")
 469 (autoload 'mml2015-verify-test "mml2015")
 470 (autoload 'mml-smime-verify "mml-smime")
 471 (autoload 'mml-smime-verify-test "mml-smime")
 472
 473 (defvar mm-verify-function-alist
 474   '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test)
 475     ("application/x-gnus-pgp-signature" mm-uu-pgp-signed-extract-1 "PGP"
 476      mm-uu-pgp-signed-test)
 477     ("application/pkcs7-signature" mml-smime-verify "S/MIME"
 478      mml-smime-verify-test)
 479     ("application/x-pkcs7-signature" mml-smime-verify "S/MIME"
 480      mml-smime-verify-test)))
 481
 482 (defcustom mm-verify-option 'never
 483   "Option of verifying signed parts.
 484 `never', not verify; `always', always verify;
 485 `known', only verify known protocols.  Otherwise, ask user.
 486
 487 When set to `always' or `known', you should add
 488 \"multipart/signed\" to `gnus-buttonized-mime-types' to see
 489 result of the verification."
 490   :version "22.1"
 491   :type '(choice (item always)
 492                  (item never)
 493                  (item :tag "only known protocols" known)
 494                  (item :tag "ask" nil))
 495   :group 'mime-security)
 496
 497 (autoload 'mml2015-decrypt "mml2015")
 498 (autoload 'mml2015-decrypt-test "mml2015")
 499
 500 (defvar mm-decrypt-function-alist
 501   '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test)
 502     ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP"
 503      mm-uu-pgp-encrypted-test)))
 504
 505 (defcustom mm-decrypt-option nil
 506   "Option of decrypting encrypted parts.
 507 `never', not decrypt; `always', always decrypt;
 508 `known', only decrypt known protocols.  Otherwise, ask user."
 509   :version "22.1"
 510   :type '(choice (item always)
 511                  (item never)
 512                  (item :tag "only known protocols" known)
 513                  (item :tag "ask" nil))
 514   :group 'mime-security)
 515
 516 (defvar mm-viewer-completion-map
 517   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
 518     (set-keymap-parent map minibuffer-local-completion-map)
 519     ;; Should we bind other key to minibuffer-complete-word?
 520     (define-key map " " 'self-insert-command)
 521     map)
 522   "Keymap for input viewer with completion.")
 523
 524 (defvar mm-viewer-completion-map
 525   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
 526     (set-keymap-parent map minibuffer-local-completion-map)
 527     ;; Should we bind other key to minibuffer-complete-word?
 528     (define-key map " " 'self-insert-command)
 529     map)
 530   "Keymap for input viewer with completion.")
 531
 532 ;;; The functions.
 533
 534 (defun mm-alist-to-plist (alist)
 535   "Convert association list ALIST into the equivalent property-list form.
 536 The plist is returned.  This converts from
 537
 538 \((a . 1) (b . 2) (c . 3))
 539
 540 into
 541
 542 \(a 1 b 2 c 3)
 543
 544 The original alist is not modified.  See also `destructive-alist-to-plist'."
 545   (let (plist)
 546     (while alist
 547       (let ((el (car alist)))
 548         (setq plist (cons (cdr el) (cons (car el) plist))))
 549       (setq alist (cdr alist)))
 550     (nreverse plist)))
 551
 552 (defun mm-keep-viewer-alive-p (handle)
 553   "Say whether external viewer for HANDLE should stay alive."
 554   (let ((types mm-keep-viewer-alive-types)
 555         (type (mm-handle-media-type handle))
 556         ty)
 557     (catch 'found
 558       (while (setq ty (pop types))
 559         (when (string-match ty type)
 560           (throw 'found t))))))
 561
 562 (defun mm-handle-set-external-undisplayer (handle function)
 563   "Set the undisplayer for HANDLE to FUNCTION.
 564 Postpone undisplaying of viewers for types in
 565 `mm-keep-viewer-alive-types'."
 566   (if (mm-keep-viewer-alive-p handle)
 567       (let ((new-handle (copy-sequence handle)))
 568         (mm-handle-set-undisplayer new-handle function)
 569         (mm-handle-set-undisplayer handle nil)
 570         (push new-handle mm-postponed-undisplay-list))
 571     (mm-handle-set-undisplayer handle function)))
 572
 573 (defun mm-destroy-postponed-undisplay-list ()
 574   (when mm-postponed-undisplay-list
 575     (message "Destroying external MIME viewers")
 576     (mm-destroy-parts mm-postponed-undisplay-list)))
 577
 578 (autoload 'message-fetch-field "message")
 579
 580 (defun mm-dissect-buffer (&optional no-strict-mime loose-mime from)
 581   "Dissect the current buffer and return a list of MIME handles.
 582 If NO-STRICT-MIME, don't require the message to have a
 583 MIME-Version header before proceeding."
 584   (save-excursion
 585     (let (ct ctl type subtype cte cd description id result)
 586       (save-restriction
 587         (mail-narrow-to-head)
 588         (when (or no-strict-mime
 589                   loose-mime
 590                   (mail-fetch-field "mime-version"))
 591           (setq ct (mail-fetch-field "content-type")
 592                 ctl (and ct (mail-header-parse-content-type ct))
 593                 cte (mail-fetch-field "content-transfer-encoding")
 594                 cd (or (mail-fetch-field "content-disposition")
 595                        (when (and ctl
 596                                   (eq 'mm-inline-text
 597                                       (cadr (mm-assoc-string-match
 598                                              mm-inline-media-tests
 599                                              (car ctl)))))
 600                          "inline"))
 601                 ;; Newlines in description should be stripped so as
 602                 ;; not to break the MIME tag into two or more lines.
 603                 description (message-fetch-field "content-description")
 604                 id (mail-fetch-field "content-id"))
 605           (unless from
 606             (setq from (mail-fetch-field "from")))
 607           ;; FIXME: In some circumstances, this code is running within
 608           ;; an unibyte macro.  mail-extract-address-components
 609           ;; creates unibyte buffers. This `if', though not a perfect
 610           ;; solution, avoids most of them.
 611           (if from
 612               (setq from (cadr (mail-extract-address-components from))))
 613           (if description
 614               (setq description (mail-decode-encoded-word-string
 615                                  description)))))
 616       (if (or (not ctl)
 617               (not (string-match "/" (car ctl))))
 618           (mm-dissect-singlepart
 619            (list mm-dissect-default-type)
 620            (and cte (intern (downcase (mail-header-strip cte))))
 621            no-strict-mime
 622            (and cd (mail-header-parse-content-disposition cd))
 623            description)
 624         (setq type (split-string (car ctl) "/"))
 625         (setq subtype (cadr type)
 626               type (car type))
 627         (setq
 628          result
 629          (cond
 630           ((equal type "multipart")
 631            (let ((mm-dissect-default-type (if (equal subtype "digest")
 632                                               "message/rfc822"
 633                                             "text/plain"))
 634                  (start (cdr (assq 'start (cdr ctl)))))
 635              (add-text-properties 0 (length (car ctl))
 636                                   (mm-alist-to-plist (cdr ctl)) (car ctl))
 637
 638              ;; what really needs to be done here is a way to link a
 639              ;; MIME handle back to it's parent MIME handle (in a multilevel
 640              ;; MIME article).  That would probably require changing
 641              ;; the mm-handle API so we simply store the multipart buffer
 642              ;; name as a text property of the "multipart/whatever" string.
 643              (add-text-properties 0 (length (car ctl))
 644                                   (list 'buffer (mm-copy-to-buffer)
 645                                         'from from
 646                                         'start start)
 647                                   (car ctl))
 648              (cons (car ctl) (mm-dissect-multipart ctl from))))
 649           (t
 650            (mm-possibly-verify-or-decrypt
 651             (mm-dissect-singlepart
 652              ctl
 653              (and cte (intern (downcase (mail-header-strip cte))))
 654              no-strict-mime
 655              (and cd (mail-header-parse-content-disposition cd))
 656              description id)
 657             ctl from))))
 658         (when id
 659           (when (string-match " *<\\(.*\\)> *" id)
 660             (setq id (match-string 1 id)))
 661           (push (cons id result) mm-content-id-alist))
 662         result))))
 663
 664 (defun mm-dissect-singlepart (ctl cte &optional force cdl description id)
 665   (when (or force
 666             (if (equal "text/plain" (car ctl))
 667                 (assoc 'format ctl)
 668               t))
 669     ;; Guess what the type of application/octet-stream parts should
 670     ;; really be.
 671     (let ((filename (cdr (assq 'filename (cdr cdl)))))
 672       (when (and (not mm-inhibit-auto-detect-attachment)
 673                  (equal (car ctl) "application/octet-stream")
 674                  filename
 675                  (string-match "\\.\\([^.]+\\)$" filename))
 676         (let ((new-type (mailcap-extension-to-mime (match-string 1 filename))))
 677           (when new-type
 678             (setcar ctl new-type)))))
 679     (let ((handle
 680            (mm-make-handle
 681             (mm-copy-to-buffer) ctl cte nil cdl description nil id))
 682           (decoder (assoc (car ctl) (mm-archive-decoders))))
 683       (if (and decoder
 684                ;; Do automatic decoding
 685                (cadr decoder)
 686                (executable-find (caddr decoder)))
 687           (mm-dissect-archive handle)
 688         handle))))
 689
 690 (defun mm-dissect-multipart (ctl from)
 691   (goto-char (point-min))
 692   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 693          (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
 694          start parts
 695          (end (save-excursion
 696                 (goto-char (point-max))
 697                 (if (re-search-backward close-delimiter nil t)
 698                     (match-beginning 0)
 699                   (point-max))))
 700          (mm-inhibit-auto-detect-attachment
 701           (equal (car ctl) "multipart/encrypted")))
 702     (setq boundary (concat (regexp-quote boundary) "[ \t]*$"))
 703     (while (and (< (point) end) (re-search-forward boundary end t))
 704       (goto-char (match-beginning 0))
 705       (when start
 706         (save-excursion
 707           (save-restriction
 708             (narrow-to-region start (point))
 709             (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
 710       (end-of-line 2)
 711       (or (looking-at boundary)
 712           (forward-line 1))
 713       (setq start (point)))
 714     (when (and start (< start end))
 715       (save-excursion
 716         (save-restriction
 717           (narrow-to-region start end)
 718           (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
 719     (mm-possibly-verify-or-decrypt (nreverse parts) ctl from)))
 720
 721 (defun mm-copy-to-buffer ()
 722   "Copy the contents of the current buffer to a fresh buffer."
 723   (let ((obuf (current-buffer))
 724         (mb (mm-multibyte-p))
 725         beg)
 726     (goto-char (point-min))
 727     (search-forward-regexp "^\n" nil t)
 728     (setq beg (point))
 729     (with-current-buffer
 730           (generate-new-buffer " *mm*")
 731       ;; Preserve the data's unibyteness (for url-insert-file-contents).
 732       (mm-set-buffer-multibyte mb)
 733       (insert-buffer-substring obuf beg)
 734       (current-buffer))))
 735
 736 (defun mm-display-parts (handle &optional no-default)
 737   (if (stringp (car handle))
 738       (mapcar 'mm-display-parts (cdr handle))
 739     (if (bufferp (car handle))
 740         (save-restriction
 741           (narrow-to-region (point) (point))
 742           (mm-display-part handle)
 743           (goto-char (point-max)))
 744       (mapcar 'mm-display-parts handle))))
 745
 746 (autoload 'mailcap-parse-mailcaps "mailcap")
 747 (autoload 'mailcap-mime-info "mailcap")
 748
 749 (defun mm-display-part (handle &optional no-default force)
 750   "Display the MIME part represented by HANDLE.
 751 Returns nil if the part is removed; inline if displayed inline;
 752 external if displayed external."
 753   (save-excursion
 754     (mailcap-parse-mailcaps)
 755     (if (and (not force)
 756              (mm-handle-displayed-p handle))
 757         (mm-remove-part handle)
 758       (let* ((ehandle (if (equal (mm-handle-media-type handle)
 759                                  "message/external-body")
 760                           (progn
 761                             (unless (mm-handle-cache handle)
 762                               (mm-extern-cache-contents handle))
 763                             (mm-handle-cache handle))
 764                         handle))
 765              (type (mm-handle-media-type ehandle))
 766              (method (mailcap-mime-info type))
 767              (filename (or (mail-content-type-get
 768                             (mm-handle-disposition handle) 'filename)
 769                            (mail-content-type-get
 770                             (mm-handle-type handle) 'name)
 771                            "<file>"))
 772              (external mm-enable-external))
 773         (if (and (mm-inlinable-p ehandle)
 774                  (mm-inlined-p ehandle))
 775             (progn
 776               (forward-line 1)
 777               (mm-display-inline handle)
 778               'inline)
 779           (when (or method
 780                     (not no-default))
 781             (if (and (not method)
 782                      (equal "text" (car (split-string type "/"))))
 783                 (progn
 784                   (forward-line 1)
 785                   (mm-insert-inline handle (mm-get-part handle))
 786                   'inline)
 787               (setq external
 788                     (and method ;; If nil, we always use "save".
 789                        (stringp method) ;; 'mailcap-save-binary-file
 790                        (or (eq mm-enable-external t)
 791                            (and (eq mm-enable-external 'ask)
 792                                 (y-or-n-p
 793                                  (concat
 794                                   "Display part (" type
 795                                   ") using external program"
 796                                   ;; Can non-string method ever happen?
 797                                   (if (stringp method)
 798                                       (concat
 799                                        " \"" (format method filename) "\"")
 800                                     "")
 801                                     "? "))))))
 802               (if external
 803                   (mm-display-external
 804                    handle (or method 'mailcap-save-binary-file))