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 (defvar gnus-current-window-configuration)
  45
  46 (add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list)
  47
  48 (defgroup mime-display ()
  49   "Display of MIME in mail and news articles."
  50   :link '(custom-manual "(emacs-mime)Display Customization")
  51   :version "21.1"
  52   :group 'mail
  53   :group 'news
  54   :group 'multimedia)
  55
  56 (defgroup mime-security ()
  57   "MIME security in mail and news articles."
  58   :link '(custom-manual "(emacs-mime)Display Customization")
  59   :group 'mail
  60   :group 'news
  61   :group 'multimedia)
  62
  63 ;;; Convenience macros.
  64
  65 (defmacro mm-handle-buffer (handle)
  66   `(nth 0 ,handle))
  67 (defmacro mm-handle-type (handle)
  68   `(nth 1 ,handle))
  69 (defsubst mm-handle-media-type (handle)
  70   (if (stringp (car handle))
  71       (car handle)
  72     (car (mm-handle-type handle))))
  73 (defsubst mm-handle-media-supertype (handle)
  74   (car (split-string (mm-handle-media-type handle) "/")))
  75 (defsubst mm-handle-media-subtype (handle)
  76   (cadr (split-string (mm-handle-media-type handle) "/")))
  77 (defmacro mm-handle-encoding (handle)
  78   `(nth 2 ,handle))
  79 (defmacro mm-handle-undisplayer (handle)
  80   `(nth 3 ,handle))
  81 (defmacro mm-handle-set-undisplayer (handle function)
  82   `(setcar (nthcdr 3 ,handle) ,function))
  83 (defmacro mm-handle-disposition (handle)
  84   `(nth 4 ,handle))
  85 (defmacro mm-handle-description (handle)
  86   `(nth 5 ,handle))
  87 (defmacro mm-handle-cache (handle)
  88   `(nth 6 ,handle))
  89 (defmacro mm-handle-set-cache (handle contents)
  90   `(setcar (nthcdr 6 ,handle) ,contents))
  91 (defmacro mm-handle-id (handle)
  92   `(nth 7 ,handle))
  93 (defmacro mm-handle-multipart-original-buffer (handle)
  94   `(get-text-property 0 'buffer (car ,handle)))
  95 (defmacro mm-handle-multipart-from (handle)
  96   `(get-text-property 0 'from (car ,handle)))
  97 (defmacro mm-handle-multipart-ctl-parameter (handle parameter)
  98   `(get-text-property 0 ,parameter (car ,handle)))
  99
 100 (defmacro mm-make-handle (&optional buffer type encoding undisplayer
 101                                     disposition description cache
 102                                     id)
 103   `(list ,buffer ,type ,encoding ,undisplayer
 104          ,disposition ,description ,cache ,id))
 105
 106 (defcustom mm-text-html-renderer
 107   (cond ((fboundp 'libxml-parse-html-region) 'shr)
 108         ((executable-find "w3m") 'gnus-w3m)
 109         ((executable-find "links") 'links)
 110         ((executable-find "lynx") 'lynx)
 111         ((locate-library "w3") 'w3)
 112         ((locate-library "html2text") 'html2text)
 113         (t nil))
 114   "Render of HTML contents.
 115 It is one of defined renderer types, or a rendering function.
 116 The defined renderer types are:
 117 `shr': use the built-in Gnus HTML renderer;
 118 `gnus-w3m': use Gnus renderer based on w3m;
 119 `w3m': use emacs-w3m;
 120 `w3m-standalone': use plain w3m;
 121 `links': use links;
 122 `lynx': use lynx;
 123 `w3': use Emacs/W3;
 124 `html2text': use html2text;
 125 nil    : use external viewer (default web browser)."
 126   :version "24.1"
 127   :type '(choice (const shr)
 128                  (const gnus-w3m)
 129                  (const w3)
 130                  (const w3m :tag "emacs-w3m")
 131                  (const w3m-standalone :tag "standalone w3m" )
 132                  (const links)
 133                  (const lynx)
 134                  (const html2text)
 135                  (const nil :tag "External viewer")
 136                  (function))
 137   :group 'mime-display)
 138
 139 (defcustom mm-inline-text-html-with-images nil
 140   "If non-nil, Gnus will allow retrieving images in HTML contents with
 141 the <img> tags.  It has no effect on Emacs/w3.  See also the
 142 documentation for the `mm-w3m-safe-url-regexp' variable."
 143   :version "22.1"
 144   :type 'boolean
 145   :group 'mime-display)
 146
 147 (defcustom mm-w3m-safe-url-regexp "\\`cid:"
 148   "Regexp matching URLs which are considered to be safe.
 149 Some HTML mails might contain a nasty trick used by spammers, using
 150 the <img> tag which is far more evil than the [Click Here!] button.
 151 It is most likely intended to check whether the ominous spam mail has
 152 reached your eyes or not, in which case the spammer knows for sure
 153 that your email address is valid.  It is done by embedding an
 154 identifier string into a URL that you might automatically retrieve
 155 when displaying the image.  The default value is \"\\\\`cid:\" which only
 156 matches parts embedded to the Multipart/Related type MIME contents and
 157 Gnus will never connect to the spammer's site arbitrarily.  You may
 158 set this variable to nil if you consider all urls to be safe."
 159   :version "22.1"
 160   :type '(choice (regexp :tag "Regexp")
 161                  (const :tag "All URLs are safe" nil))
 162   :group 'mime-display)
 163
 164 (defcustom mm-inline-text-html-with-w3m-keymap t
 165   "If non-nil, use emacs-w3m command keys in the article buffer."
 166   :version "22.1"
 167   :type 'boolean
 168   :group 'mime-display)
 169
 170 (defcustom mm-enable-external t
 171   "Indicate whether external MIME handlers should be used.
 172
 173 If t, all defined external MIME handlers are used.  If nil, files are saved by
 174 `mailcap-save-binary-file'.  If it is the symbol `ask', you are prompted
 175 before the external MIME handler is invoked."
 176   :version "22.1"
 177   :type '(choice (const :tag "Always" t)
 178                  (const :tag "Never" nil)
 179                  (const :tag "Ask" ask))
 180   :group 'mime-display)
 181
 182 (defcustom mm-inline-media-tests
 183   '(("image/p?jpeg"
 184      mm-inline-image
 185      (lambda (handle)
 186        (mm-valid-and-fit-image-p 'jpeg handle)))
 187     ("image/png"
 188      mm-inline-image
 189      (lambda (handle)
 190        (mm-valid-and-fit-image-p 'png handle)))
 191     ("image/gif"
 192      mm-inline-image
 193      (lambda (handle)
 194        (mm-valid-and-fit-image-p 'gif handle)))
 195     ("image/tiff"
 196      mm-inline-image
 197      (lambda (handle)
 198        (mm-valid-and-fit-image-p 'tiff handle)))
 199     ("image/xbm"
 200      mm-inline-image
 201      (lambda (handle)
 202        (mm-valid-and-fit-image-p 'xbm handle)))
 203     ("image/x-xbitmap"
 204      mm-inline-image
 205      (lambda (handle)
 206        (mm-valid-and-fit-image-p 'xbm handle)))
 207     ("image/xpm"
 208      mm-inline-image
 209      (lambda (handle)
 210        (mm-valid-and-fit-image-p 'xpm handle)))
 211     ("image/x-xpixmap"
 212      mm-inline-image
 213      (lambda (handle)
 214        (mm-valid-and-fit-image-p 'xpm handle)))
 215     ("image/bmp"
 216      mm-inline-image
 217      (lambda (handle)
 218        (mm-valid-and-fit-image-p 'bmp handle)))
 219     ("image/x-portable-bitmap"
 220      mm-inline-image
 221      (lambda (handle)
 222        (mm-valid-and-fit-image-p 'pbm handle)))
 223     ("text/plain" mm-inline-text identity)
 224     ("text/enriched" mm-inline-text identity)
 225     ("text/richtext" mm-inline-text identity)
 226     ("text/x-patch" mm-display-patch-inline identity)
 227     ;; In case mime.types uses x-diff (as does Debian's mime-support-3.40).
 228     ("text/x-diff" mm-display-patch-inline identity)
 229     ("application/emacs-lisp" mm-display-elisp-inline identity)
 230     ("application/x-emacs-lisp" mm-display-elisp-inline identity)
 231     ("application/x-shellscript" mm-display-shell-script-inline identity)
 232     ("application/x-sh" mm-display-shell-script-inline identity)
 233     ("text/x-sh" mm-display-shell-script-inline identity)
 234     ("application/javascript" mm-display-javascript-inline identity)
 235     ("text/dns" mm-display-dns-inline identity)
 236     ("text/x-org" mm-display-org-inline identity)
 237     ("text/html"
 238      mm-inline-text-html
 239      (lambda (handle)
 240        mm-text-html-renderer))
 241     ("text/x-vcard"
 242      mm-inline-text-vcard
 243      (lambda (handle)
 244        (or (featurep 'vcard)
 245            (locate-library "vcard"))))
 246     ("message/delivery-status" mm-inline-text identity)
 247     ("message/rfc822" mm-inline-message identity)
 248     ("message/partial" mm-inline-partial identity)
 249     ("message/external-body" mm-inline-external-body identity)
 250     ("text/.*" mm-inline-text identity)
 251     ("audio/wav" mm-inline-audio
 252      (lambda (handle)
 253        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 254             (device-sound-enabled-p))))
 255     ("audio/au"
 256      mm-inline-audio
 257      (lambda (handle)
 258        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 259             (device-sound-enabled-p))))
 260     ("application/pgp-signature" ignore identity)
 261     ("application/x-pkcs7-signature" ignore identity)
 262     ("application/pkcs7-signature" ignore identity)
 263     ("application/x-pkcs7-mime" ignore identity)
 264     ("application/pkcs7-mime" ignore identity)
 265     ("multipart/alternative" ignore identity)
 266     ("multipart/mixed" ignore identity)
 267     ("multipart/related" ignore identity)
 268     ("image/.*"
 269      mm-inline-image
 270      (lambda (handle)
 271        (and (mm-valid-image-format-p 'imagemagick)
 272             (mm-with-unibyte-buffer
 273               (mm-insert-part handle)
 274               (let ((image
 275                      (ignore-errors
 276                        (if (fboundp 'create-image)
 277                            (create-image (buffer-string) 'imagemagick 'data-p)
 278                          (mm-create-image-xemacs (mm-handle-media-subtype handle))))))
 279                 (when image
 280                   (setcar (cdr handle) (list "image/imagemagick"))
 281                   (mm-image-fit-p handle)))))))
 282     ;; Disable audio and image
 283     ("audio/.*" ignore ignore)
 284     ("image/.*" ignore ignore)
 285     ;; Default to displaying as text
 286     (".*" mm-inline-text mm-readable-p))
 287   "Alist of media types/tests saying whether types can be displayed inline."
 288   :type '(repeat (list (regexp :tag "MIME type")
 289                        (function :tag "Display function")
 290                        (function :tag "Display test")))
 291   :group 'mime-display)
 292
 293 (defcustom mm-inlined-types
 294   '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
 295     "message/partial" "message/external-body" "application/emacs-lisp"
 296     "application/x-emacs-lisp"
 297     "application/pgp-signature" "application/x-pkcs7-signature"
 298     "application/pkcs7-signature" "application/x-pkcs7-mime"
 299     "application/pkcs7-mime"
 300     ;; Mutt still uses this even though it has already been withdrawn.
 301     "application/pgp")
 302   "List of media types that are to be displayed inline.
 303 See also `mm-inline-media-tests', which says how to display a media
 304 type inline."
 305   :type '(repeat regexp)
 306   :group 'mime-display)
 307
 308 (defcustom mm-keep-viewer-alive-types
 309   '("application/postscript" "application/msword" "application/vnd.ms-excel"
 310     "application/pdf" "application/x-dvi")
 311   "List of media types for which the external viewer will not be killed
 312 when selecting a different article."
 313   :version "22.1"
 314   :type '(repeat regexp)
 315   :group 'mime-display)
 316
 317 (defcustom mm-automatic-display
 318   '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-verbatim"
 319     "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
 320     "message/rfc822" "text/x-patch" "text/dns" "application/pgp-signature"
 321     "application/emacs-lisp" "application/x-emacs-lisp"
 322     "application/x-pkcs7-signature"
 323     "application/pkcs7-signature" "application/x-pkcs7-mime"
 324     "application/pkcs7-mime"
 325     ;; Mutt still uses this even though it has already been withdrawn.
 326     "application/pgp\\'"
 327      "text/x-org")
 328   "A list of MIME types to be displayed automatically."
 329   :type '(repeat regexp)
 330   :group 'mime-display)
 331
 332 (defcustom mm-attachment-override-types '("text/x-vcard"
 333                                           "application/pkcs7-mime"
 334                                           "application/x-pkcs7-mime"
 335                                           "application/pkcs7-signature"
 336                                           "application/x-pkcs7-signature")
 337   "Types to have \"attachment\" ignored if they can be displayed inline."
 338   :type '(repeat regexp)
 339   :group 'mime-display)
 340
 341 (defcustom mm-inline-override-types nil
 342   "Types to be treated as attachments even if they can be displayed inline."
 343   :type '(repeat regexp)
 344   :group 'mime-display)
 345
 346 (defcustom mm-automatic-external-display nil
 347   "List of MIME type regexps that will be displayed externally automatically."
 348   :type '(repeat regexp)
 349   :group 'mime-display)
 350
 351 (defcustom mm-discouraged-alternatives nil
 352   "List of MIME types that are discouraged when viewing multipart/alternative.
 353 Viewing agents are supposed to view the last possible part of a message,
 354 as that is supposed to be the richest.  However, users may prefer other
 355 types instead, and this list says what types are most unwanted.  If,
 356 for instance, text/html parts are very unwanted, and text/richtext are
 357 somewhat unwanted, then the value of this variable should be set
 358 to:
 359
 360  (\"text/html\" \"text/richtext\")
 361
 362 Adding \"image/.*\" might also be useful.  Spammers use it as the
 363 preferred part of multipart/alternative messages.  See also
 364 `gnus-buttonized-mime-types', to which adding \"multipart/alternative\"
 365 enables you to choose manually one of two types those mails include."
 366   :type '(repeat regexp) ;; See `mm-preferred-alternative-precedence'.
 367   :group 'mime-display)
 368
 369 (defcustom mm-tmp-directory
 370   (if (fboundp 'temp-directory)
 371       (temp-directory)
 372     (if (boundp 'temporary-file-directory)
 373         temporary-file-directory
 374       "/tmp/"))
 375   "Where mm will store its temporary files."
 376   :type 'directory
 377   :group 'mime-display)
 378
 379 (defcustom mm-inline-large-images nil
 380   "If t, then all images fit in the buffer.
 381 If 'resize, try to resize the images so they fit."
 382   :type '(radio
 383           (const :tag "Inline large images as they are." t)
 384           (const :tag "Resize large images." resize)
 385           (const :tag "Do not inline large images." nil))
 386   :group 'mime-display)
 387
 388 (defcustom mm-file-name-rewrite-functions
 389   '(mm-file-name-delete-control mm-file-name-delete-gotchas)
 390   "List of functions used for rewriting file names of MIME parts.
 391 Each function takes a file name as input and returns a file name.
 392
 393 Ready-made functions include `mm-file-name-delete-control',
 394 `mm-file-name-delete-gotchas' (you should not remove these two
 395 functions), `mm-file-name-delete-whitespace',
 396 `mm-file-name-trim-whitespace', `mm-file-name-collapse-whitespace',
 397 `mm-file-name-replace-whitespace', `capitalize', `downcase',
 398 `upcase', and `upcase-initials'."
 399   :type '(list (set :inline t
 400                     (const mm-file-name-delete-control)
 401                     (const mm-file-name-delete-gotchas)
 402                     (const mm-file-name-delete-whitespace)
 403                     (const mm-file-name-trim-whitespace)
 404                     (const mm-file-name-collapse-whitespace)
 405                     (const mm-file-name-replace-whitespace)
 406                     (const capitalize)
 407                     (const downcase)
 408                     (const upcase)
 409                     (const upcase-initials)
 410                (repeat :inline t
 411                        :tag "Function"
 412                        function)))
 413   :version "23.1" ;; No Gnus
 414   :group 'mime-display)
 415
 416
 417 (defvar mm-path-name-rewrite-functions nil
 418   "*List of functions for rewriting the full file names of MIME parts.
 419 This is used when viewing parts externally, and is meant for
 420 transforming the absolute name so that non-compliant programs can find
 421 the file where it's saved.
 422
 423 Each function takes a file name as input and returns a file name.")
 424
 425 (defvar mm-file-name-replace-whitespace nil
 426   "String used for replacing whitespace characters; default is `\"_\"'.")
 427
 428 (defcustom mm-default-directory nil
 429   "The default directory where mm will save files.
 430 If not set, `default-directory' will be used."
 431   :type '(choice directory (const :tag "Default" nil))
 432   :group 'mime-display)
 433
 434 (defcustom mm-attachment-file-modes 384
 435   "Set the mode bits of saved attachments to this integer."
 436   :version "22.1"
 437   :type 'integer
 438   :group 'mime-display)
 439
 440 (defcustom mm-external-terminal-program "xterm"
 441   "The program to start an external terminal."
 442   :version "22.1"
 443   :type 'string
 444   :group 'mime-display)
 445
 446 ;;; Internal variables.
 447
 448 (defvar mm-last-shell-command "")
 449 (defvar mm-content-id-alist nil)
 450 (defvar mm-postponed-undisplay-list nil)
 451
 452 ;; According to RFC2046, in particular, in a digest, the default
 453 ;; Content-Type value for a body part is changed from "text/plain" to
 454 ;; "message/rfc822".
 455 (defvar mm-dissect-default-type "text/plain")
 456
 457 (autoload 'mml2015-verify "mml2015")
 458 (autoload 'mml2015-verify-test "mml2015")
 459 (autoload 'mml-smime-verify "mml-smime")
 460 (autoload 'mml-smime-verify-test "mml-smime")
 461
 462 (defvar mm-verify-function-alist
 463   '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test)
 464     ("application/x-gnus-pgp-signature" mm-uu-pgp-signed-extract-1 "PGP"
 465      mm-uu-pgp-signed-test)
 466     ("application/pkcs7-signature" mml-smime-verify "S/MIME"
 467      mml-smime-verify-test)
 468     ("application/x-pkcs7-signature" mml-smime-verify "S/MIME"
 469      mml-smime-verify-test)))
 470
 471 (defcustom mm-verify-option 'never
 472   "Option of verifying signed parts.
 473 `never', not verify; `always', always verify;
 474 `known', only verify known protocols.  Otherwise, ask user.
 475
 476 When set to `always' or `known', you should add
 477 \"multipart/signed\" to `gnus-buttonized-mime-types' to see
 478 result of the verification."
 479   :version "22.1"
 480   :type '(choice (item always)
 481                  (item never)
 482                  (item :tag "only known protocols" known)
 483                  (item :tag "ask" nil))
 484   :group 'mime-security)
 485
 486 (autoload 'mml2015-decrypt "mml2015")
 487 (autoload 'mml2015-decrypt-test "mml2015")
 488
 489 (defvar mm-decrypt-function-alist
 490   '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test)
 491     ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP"
 492      mm-uu-pgp-encrypted-test)))
 493
 494 (defcustom mm-decrypt-option nil
 495   "Option of decrypting encrypted parts.
 496 `never', not decrypt; `always', always decrypt;
 497 `known', only decrypt known protocols.  Otherwise, ask user."
 498   :version "22.1"
 499   :type '(choice (item always)
 500                  (item never)
 501                  (item :tag "only known protocols" known)
 502                  (item :tag "ask" nil))
 503   :group 'mime-security)
 504
 505 (defvar mm-viewer-completion-map
 506   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
 507     (set-keymap-parent map minibuffer-local-completion-map)
 508     ;; Should we bind other key to minibuffer-complete-word?
 509     (define-key map " " 'self-insert-command)
 510     map)
 511   "Keymap for input viewer with completion.")
 512
 513 (defvar mm-viewer-completion-map
 514   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
 515     (set-keymap-parent map minibuffer-local-completion-map)
 516     ;; Should we bind other key to minibuffer-complete-word?
 517     (define-key map " " 'self-insert-command)
 518     map)
 519   "Keymap for input viewer with completion.")
 520
 521 ;;; The functions.
 522
 523 (defun mm-alist-to-plist (alist)
 524   "Convert association list ALIST into the equivalent property-list form.
 525 The plist is returned.  This converts from
 526
 527 \((a . 1) (b . 2) (c . 3))
 528
 529 into
 530
 531 \(a 1 b 2 c 3)
 532
 533 The original alist is not modified.  See also `destructive-alist-to-plist'."
 534   (let (plist)
 535     (while alist
 536       (let ((el (car alist)))
 537         (setq plist (cons (cdr el) (cons (car el) plist))))
 538       (setq alist (cdr alist)))
 539     (nreverse plist)))
 540
 541 (defun mm-keep-viewer-alive-p (handle)
 542   "Say whether external viewer for HANDLE should stay alive."
 543   (let ((types mm-keep-viewer-alive-types)
 544         (type (mm-handle-media-type handle))
 545         ty)
 546     (catch 'found
 547       (while (setq ty (pop types))
 548         (when (string-match ty type)
 549           (throw 'found t))))))
 550
 551 (defun mm-handle-set-external-undisplayer (handle function)
 552   "Set the undisplayer for HANDLE to FUNCTION.
 553 Postpone undisplaying of viewers for types in
 554 `mm-keep-viewer-alive-types'."
 555   (if (mm-keep-viewer-alive-p handle)
 556       (let ((new-handle (copy-sequence handle)))
 557         (mm-handle-set-undisplayer new-handle function)
 558         (mm-handle-set-undisplayer handle nil)
 559         (push new-handle mm-postponed-undisplay-list))
 560     (mm-handle-set-undisplayer handle function)))
 561
 562 (defun mm-destroy-postponed-undisplay-list ()
 563   (when mm-postponed-undisplay-list
 564     (message "Destroying external MIME viewers")
 565     (mm-destroy-parts mm-postponed-undisplay-list)))
 566
 567 (autoload 'message-fetch-field "message")
 568
 569 (defun mm-dissect-buffer (&optional no-strict-mime loose-mime from)
 570   "Dissect the current buffer and return a list of MIME handles."
 571   (save-excursion
 572     (let (ct ctl type subtype cte cd description id result)
 573       (save-restriction
 574         (mail-narrow-to-head)
 575         (when (or no-strict-mime
 576                   loose-mime
 577                   (mail-fetch-field "mime-version"))
 578           (setq ct (mail-fetch-field "content-type")
 579                 ctl (and ct (mail-header-parse-content-type ct))
 580                 cte (mail-fetch-field "content-transfer-encoding")
 581                 cd (or (mail-fetch-field "content-disposition")
 582                        (when (and ctl
 583                                   (eq 'mm-inline-text
 584                                       (cadr (mm-assoc-string-match
 585                                              mm-inline-media-tests
 586                                              (car ctl)))))
 587                          "inline"))
 588                 ;; Newlines in description should be stripped so as
 589                 ;; not to break the MIME tag into two or more lines.
 590                 description (message-fetch-field "content-description")
 591                 id (mail-fetch-field "content-id"))
 592           (unless from
 593             (setq from (mail-fetch-field "from")))
 594           ;; FIXME: In some circumstances, this code is running within
 595           ;; an unibyte macro.  mail-extract-address-components
 596           ;; creates unibyte buffers. This `if', though not a perfect
 597           ;; solution, avoids most of them.
 598           (if from
 599               (setq from (cadr (mail-extract-address-components from))))
 600           (if description
 601               (setq description (mail-decode-encoded-word-string
 602                                  description)))))
 603       (if (or (not ctl)
 604               (not (string-match "/" (car ctl))))
 605           (mm-dissect-singlepart
 606            (list mm-dissect-default-type)
 607            (and cte (intern (downcase (mail-header-strip cte))))
 608            no-strict-mime
 609            (and cd (mail-header-parse-content-disposition cd))
 610            description)
 611         (setq type (split-string (car ctl) "/"))
 612         (setq subtype (cadr type)
 613               type (car type))
 614         (setq
 615          result
 616          (cond
 617           ((equal type "multipart")
 618            (let ((mm-dissect-default-type (if (equal subtype "digest")
 619                                               "message/rfc822"
 620                                             "text/plain"))
 621                  (start (cdr (assq 'start (cdr ctl)))))
 622              (add-text-properties 0 (length (car ctl))
 623                                   (mm-alist-to-plist (cdr ctl)) (car ctl))
 624
 625              ;; what really needs to be done here is a way to link a
 626              ;; MIME handle back to it's parent MIME handle (in a multilevel
 627              ;; MIME article).  That would probably require changing
 628              ;; the mm-handle API so we simply store the multipart buffer
 629              ;; name as a text property of the "multipart/whatever" string.
 630              (add-text-properties 0 (length (car ctl))
 631                                   (list 'buffer (mm-copy-to-buffer)
 632                                         'from from
 633                                         'start start)
 634                                   (car ctl))
 635              (cons (car ctl) (mm-dissect-multipart ctl from))))
 636           (t
 637            (mm-possibly-verify-or-decrypt
 638             (mm-dissect-singlepart
 639              ctl
 640              (and cte (intern (downcase (mail-header-strip cte))))
 641              no-strict-mime
 642              (and cd (mail-header-parse-content-disposition cd))
 643              description id)
 644             ctl from))))
 645         (when id
 646           (when (string-match " *<\\(.*\\)> *" id)
 647             (setq id (match-string 1 id)))
 648           (push (cons id result) mm-content-id-alist))
 649         result))))
 650
 651 (defun mm-dissect-singlepart (ctl cte &optional force cdl description id)
 652   (when (or force
 653             (if (equal "text/plain" (car ctl))
 654                 (assoc 'format ctl)
 655               t))
 656     (mm-make-handle
 657      (mm-copy-to-buffer) ctl cte nil cdl description nil id)))
 658
 659 (defun mm-dissect-multipart (ctl from)
 660   (goto-char (point-min))
 661   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 662          (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
 663          start parts
 664          (end (save-excursion
 665                 (goto-char (point-max))
 666                 (if (re-search-backward close-delimiter nil t)
 667                     (match-beginning 0)
 668                   (point-max)))))
 669     (setq boundary (concat (regexp-quote boundary) "[ \t]*$"))
 670     (while (and (< (point) end) (re-search-forward boundary end t))
 671       (goto-char (match-beginning 0))
 672       (when start
 673         (save-excursion
 674           (save-restriction
 675             (narrow-to-region start (point))
 676             (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
 677       (end-of-line 2)
 678       (or (looking-at boundary)
 679           (forward-line 1))
 680       (setq start (point)))
 681     (when (and start (< start end))
 682       (save-excursion
 683         (save-restriction
 684           (narrow-to-region start end)
 685           (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
 686     (mm-possibly-verify-or-decrypt (nreverse parts) ctl from)))
 687
 688 (defun mm-copy-to-buffer ()
 689   "Copy the contents of the current buffer to a fresh buffer."
 690   (let ((obuf (current-buffer))
 691         (mb (mm-multibyte-p))
 692         beg)
 693     (goto-char (point-min))
 694     (search-forward-regexp "^\n" nil t)
 695     (setq beg (point))
 696     (with-current-buffer
 697           (generate-new-buffer " *mm*")
 698       ;; Preserve the data's unibyteness (for url-insert-file-contents).
 699       (mm-set-buffer-multibyte mb)
 700       (insert-buffer-substring obuf beg)
 701       (current-buffer))))
 702
 703 (defun mm-display-parts (handle &optional no-default)
 704   (if (stringp (car handle))
 705       (mapcar 'mm-display-parts (cdr handle))
 706     (if (bufferp (car handle))
 707         (save-restriction
 708           (narrow-to-region (point) (point))
 709           (mm-display-part handle)
 710           (goto-char (point-max)))
 711       (mapcar 'mm-display-parts handle))))
 712
 713 (autoload 'mailcap-parse-mailcaps "mailcap")
 714 (autoload 'mailcap-mime-info "mailcap")
 715
 716 (defun mm-display-part (handle &optional no-default force)
 717   "Display the MIME part represented by HANDLE.
 718 Returns nil if the part is removed; inline if displayed inline;
 719 external if displayed external."
 720   (save-excursion
 721     (mailcap-parse-mailcaps)
 722     (if (and (not force)
 723              (mm-handle-displayed-p handle))
 724         (mm-remove-part handle)
 725       (let* ((ehandle (if (equal (mm-handle-media-type handle)
 726                                  "message/external-body")
 727                           (progn
 728                             (unless (mm-handle-cache handle)
 729                               (mm-extern-cache-contents handle))
 730                             (mm-handle-cache handle))
 731                         handle))
 732              (type (mm-handle-media-type ehandle))
 733              (method (mailcap-mime-info type))
 734              (filename (or (mail-content-type-get
 735                             (mm-handle-disposition handle) 'filename)
 736                            (mail-content-type-get
 737                             (mm-handle-type handle) 'name)
 738                            "<file>"))
 739              (external mm-enable-external))
 740         (if (and (mm-inlinable-p ehandle)
 741                  (mm-inlined-p ehandle))
 742             (progn
 743               (forward-line 1)
 744               (mm-display-inline handle)
 745               'inline)
 746           (when (or method
 747                     (not no-default))
 748             (if (and (not method)
 749                      (equal "text" (car (split-string type "/"))))
 750                 (progn
 751                   (forward-line 1)
 752                   (mm-insert-inline handle (mm-get-part handle))
 753                   'inline)
 754               (setq external
 755                     (and method ;; If nil, we always use "save".
 756                        (stringp method) ;; 'mailcap-save-binary-file
 757                        (or (eq mm-enable-external t)
 758                            (and (eq mm-enable-external 'ask)
 759                                 (y-or-n-p
 760                                  (concat
 761                                   "Display part (" type
 762                                   ") using external program"
 763                                   ;; Can non-string method ever happen?
 764                                   (if (stringp method)
 765                                       (concat
 766                                        " \"" (format method filename) "\"")
 767                                     "")
 768                                     "? "))))))
 769               (if external
 770                   (mm-display-external
 771                    handle (or method 'mailcap-save-binary-file))
 772                 (mm-display-external
 773                  handle 'mailcap-save-binary-file)))))))))
 774
 775 (declare-function gnus-configure-windows "gnus-win" (setting &optional force))
 776 (defvar mailcap-mime-extensions)        ; mailcap-mime-info autoloads
 777
 778 (defun mm-display-external (handle method)
 779   "Display HANDLE using METHOD."
 780   (let ((outbuf (current-buffer)))
 781     (mm-with-unibyte-buffer
 782       (if (functionp method)
 783           (let ((cur (current-buffer)))
 784             (if (eq method 'mailcap-save-binary-file)
 785                 (progn
 786                   (set-buffer (generate-new-buffer " *mm*"))
 787                   (setq method nil))
 788               (mm-insert-part handle)
 789               (mm-add-meta-html-tag handle)
 790               (let ((win (get-buffer-window cur t)))
 791                 (when win
 792                   (select-window win)))
 793               (switch-to-buffer (generate-new-buffer " *mm*")))
 794             (buffer-disable-undo)
 795             (mm-set-buffer-file-coding-system mm-binary-coding-system)
 796             (insert-buffer-substring cur)
 797             (goto-char (point-min))
 798             (when method
 799               (message "Viewing with %s" method))
 800             (let ((mm (current-buffer))
 801                   (non-viewer (assq 'non-viewer
 802                                     (mailcap-mime-info
 803                                      (mm-handle-media-type handle) t))))
 804               (unwind-protect
 805                   (if method
 806                       (funcall method)
 807                     (mm-save-part handle))
 808                 (when (and (not non-viewer)
 809                            method)
 810                   (mm-handle-set-undisplayer handle mm)))))
 811         ;; The function is a string to be executed.
 812         (mm-insert-part handle)
 813         (mm-add-meta-html-tag handle)
 814         (let* ((dir (mm-make-temp-file
 815                      (expand-file-name "emm." mm-tmp-directory) 'dir))
 816                (filename (or
 817                           (mail-content-type-get
 818                            (mm-handle-disposition handle) 'filename)
 819                           (mail-content-type-get
 820                            (mm-handle-type handle) 'name)))
 821                (mime-info (mailcap-mime-info
 822                            (mm-handle-media-type handle) t))
 823                (needsterm (or (assoc "needsterm" mime-info)
 824                               (assoc "needsterminal" mime-info)))
 825                (copiousoutput (assoc "copiousoutput" mime-info))
 826                file buffer)
 827           ;; We create a private sub-directory where we store our files.
 828           (set-file-modes dir #o700)
 829           (if filename
 830               (setq file (expand-file-name
 831                           (gnus-map-function mm-file-name-rewrite-functions
 832                                              (file-name-nondirectory filename))
 833                           dir))
 834             ;; Use nametemplate (defined in RFC1524) if it is specified
 835             ;; in mailcap.
 836             (let ((suffix (cdr (assoc "nametemplate" mime-info))))
 837               (if (and suffix
 838                        (string-match "\\`%s\\(\\..+\\)\\'" suffix))
 839                   (setq suffix (match-string 1 suffix))
 840                 ;; Otherwise, use a suffix according to
 841                 ;; `mailcap-mime-extensions'.
 842                 (setq suffix (car (rassoc (mm-handle-media-type handle)
 843                                           mailcap-mime-extensions))))
 844               (setq file (mm-make-temp-file (expand-file-name "mm." dir)
 845                                             nil suffix))))
 846           (let ((coding-system-for-write mm-binary-coding-system))
 847             (write-region (point-min) (point-max) file nil 'nomesg))
 848           ;; The file is deleted after the viewer exists.  If the users edits
 849           ;; the file, changes will be lost.  Set file to read-only to make it
 850           ;; clear.
 851           (set-file-modes file #o400)
 852           (message "Viewing with %s" method)
 853           (cond
 854            (needsterm
 855             (let ((command (mm-mailcap-command
 856                             method file (mm-handle-type handle))))
 857               (unwind-protect
 858                   (if window-system
 859                       (start-process "*display*" nil
 860                                      mm-external-terminal-program
 861                                      "-e" shell-file-name
 862                                      shell-command-switch command)
 863                     (require 'term)
 864                     (require 'gnus-win)
 865                     (set-buffer
 866                      (setq buffer
 867                            (make-term "display"
 868                                       shell-file-name
 869                                       nil
 870                                       shell-command-switch command)))
 871                     (term-mode)
 872                     (term-char-mode)
 873                     (set-process-sentinel
 874                      (get-buffer-process buffer)
 875                      `(lambda (process state)
 876                         (if (eq 'exit (process-status process))
 877                             (gnus-configure-windows
 878                              ',gnus-current-window-configuration))))
 879                     (gnus-configure-windows 'display-term))
 880                 (mm-handle-set-external-undisplayer handle (cons file buffer)))
 881               (message "Displaying %s..." command))
 882             'external)
 883            (copiousoutput
 884             (with-current-buffer outbuf
 885               (forward-line 1)
 886               (mm-insert-inline
 887                handle
 888                (unwind-protect
 889                    (progn
 890                      (call-process shell-file-name nil
 891                                    (setq buffer
 892                                          (generate-new-buffer " *mm*"))
 893                                    nil
 894                                    shell-command-switch
 895                                    (mm-mailcap-command
 896                                     method file (mm-handle-type handle)))
 897                      (if (buffer-live-p buffer)
 898                          (with-current-buffer buffer
 899                            (buffer-string))))
 900                  (progn
 901                    (ignore-errors (delete-file file))
 902                    (ignore-errors (delete-directory
 903                                    (file-name-directory file)))
 904                    (ignore-errors (kill-buffer buffer))))))
 905             'inline)
 906            (t
 907             ;; Deleting the temp file should be postponed for some wrappers,
 908             ;; shell scripts, and so on, which might exit right after having
 909             ;; started a viewer command as a background job.
 910             (let ((command (mm-mailcap-command
 911                             method file (mm-handle-type handle))))
 912               (unwind-protect
 913                   (progn
 914                     (start-process "*display*"
 915                                    (setq buffer
 916                                          (generate-new-buffer " *mm*"))
 917                                    shell-file-name
 918                                    shell-command-switch command)
 919                     (set-process-sentinel
 920                      (get-buffer-process buffer)
 921                      (lexical-let ;; Don't use `let'.
 922                          ;; Function used to remove temp file and directory.
 923                          ((fn `(lambda nil
 924                                  ;; Don't use `ignore-errors'.
 925                                  (condition-case nil
 926                                      (delete-file ,file)
 927                                    (error))
 928                                  (condition-case nil
 929                                      (delete-directory
 930                                       ,(file-name-directory file))
 931                                    (error))))
 932                           ;; Form uses to kill the process buffer and
 933                           ;; remove the undisplayer.
 934                           (fm `(progn
 935                                  (kill-buffer ,buffer)
 936                                  ,(macroexpand
 937                                    (list 'mm-handle-set-undisplayer
 938                                          (list 'quote handle)
 939                                          nil))))
 940                           ;; Message to be issued when the process exits.
 941                           (done (format "Displaying %s...done" command))
 942                           ;; In particular, the timer object (which is
 943                           ;; a vector in Emacs but is a list in XEmacs)
 944                           ;; requires that it is lexically scoped.
 945                           (timer (run-at-time 30.0 nil 'ignore)))
 946                        (if (featurep 'xemacs)
 947                            (lambda (process state)
 948                              (when (eq 'exit (process-status process))
 949                                (if (memq timer itimer-list)
 950                                    (set-itimer-function timer fn)
 951                                  (funcall fn))
 952                                (ignore-errors (eval fm))
 953                                (message "%s" done)))
 954                          (lambda (process state)
 955                            (when (eq 'exit (process-status process))
 956                              (if (memq timer timer-list)
 957                                  (timer-set-function timer fn)
 958                                (funcall fn))
 959                              (ignore-errors (eval fm))
 960                              (message "%s" done)))))))
 961                 (mm-handle-set-external-undisplayer
 962                  handle (cons file buffer)))
 963               (message "Displaying %s..." command))
 964             'external)))))))
 965
 966 (defun mm-mailcap-command (method file type-list)
 967   (let ((ctl (cdr type-list))
 968         (beg 0)
 969         (uses-stdin t)
 970         out sub total)
 971     (while (string-match "%{\\([^}]+\\)}\\|'%s'\\|\"%s\"\\|%s\\|%t\\|%%"
 972                          method beg)
 973       (push (substring method beg (match-beginning 0)) out)
 974       (setq beg (match-end 0)
 975             total (match-string 0 method)
 976             sub (match-string 1 method))
 977       (cond
 978        ((string= total "%%")
 979         (push "%" out))
 980        ((or (string= total "%s")
 981             ;; We do our own quoting.
 982             (string= total "'%s'")
 983             (string= total "\"%s\""))
 984         (setq uses-stdin nil)
 985         (push (shell-quote-argument
 986                (gnus-map-function mm-path-name-rewrite-functions file)) out))
 987        ((string= total "%t")
 988         (push (shell-quote-argument (car type-list)) out))
 989        (t
 990         (push (shell-quote-argument (or (cdr (assq (intern sub) ctl)) "")) out))))
 991     (push (substring method beg (length method)) out)
 992     (when uses-stdin
 993       (push "<" out)
 994       (push (shell-quote-argument
 995              (gnus-map-function mm-path-name-rewrite-functions file))
 996             out))
 997     (mapconcat 'identity (nreverse out) "")))
 998
 999 (defun mm-remove-parts (handles)
1000   "Remove the displayed MIME parts represented by HANDLES."
1001   (if (and (listp handles)
1002            (bufferp (car handles)))
1003       (mm-remove-part handles)
1004     (let (handle)
1005       (while (setq handle (pop handles))
1006         (cond
1007          ((stringp handle)
1008           (when (buffer-live-p (get-text-property 0 'buffer handle))
1009             (kill-buffer (get-text-property 0 'buffer handle))))
1010          ((and (listp handle)
1011                (stringp (car handle)))
1012           (mm-remove-parts (cdr handle)))
1013          (t
1014           (mm-remove-part handle)))))))
1015
1016 (defun mm-destroy-parts (handles)
1017   "Remove the displayed MIME parts represented by HANDLES."
1018   (if (and (listp handles)
1019            (bufferp (car handles)))
1020       (mm-destroy-part handles)
1021     (let (handle)
1022       (while (setq handle (pop handles))
1023         (cond
1024          ((stringp handle)
1025           (when (buffer-live-p (get-text-property 0 'buffer handle))
1026             (kill-buffer (get-text-property 0 'buffer handle))))
1027          ((and (listp handle)
1028                (stringp (car handle)))
1029           (mm-destroy-parts handle))
1030          (t
1031           (mm-destroy-part handle)))))))
1032
1033 (defun mm-remove-part (handle)
1034   "Remove the displayed MIME part represented by HANDLE."
1035   (when (listp handle)
1036     (let ((object (mm-handle-undisplayer handle)))
1037       (ignore-errors
1038         (cond
1039          ;; Internally displayed part.
1040          ((mm-annotationp object)
1041           (if (featurep 'xemacs)
1042               (delete-annotation object)))
1043          ((or (functionp object)
1044               (and (listp object)
1045                    (eq (car object) 'lambda)))
1046           (funcall object))
1047          ;; Externally displayed part.
1048          ((consp object)
1049           (condition-case ()
1050               (while (get-buffer-process (cdr object))
1051                 (interrupt-process (get-buffer-process (cdr object)))
1052                 (message "Waiting for external displayer to die...")
1053                 (sit-for 1))
1054             (quit)
1055             (error))
1056           (ignore-errors (and (cdr object) (kill-buffer (cdr object))))
1057           (message "Waiting for external displayer to die...done")
1058           (ignore-errors (delete-file (car object)))
1059           (ignore-errors (delete-directory (file-name-directory
1060                                             (car object)))))
1061          ((bufferp object)
1062           (when (buffer-live-p object)
1063             (kill-buffer object)))))
1064       (mm-handle-set-undisplayer handle nil))))
1065
1066 (defun mm-display-inline (handle)
1067   (let* ((type (mm-handle-media-type handle))
1068          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
1069     (funcall function handle)
1070     (goto-char (point-min))))
1071
1072 (defun mm-assoc-string-match (alist type)
1073   (dolist (elem alist)
1074     (when (string-match (car elem) type)
1075       (return elem))))
1076
1077 (defun mm-automatic-display-p (handle)
1078   "Say whether the user wants HANDLE to be displayed automatically."
1079   (let ((methods mm-automatic-display)
1080         (type (mm-handle-media-type handle))
1081         method result)
1082     (while (setq method (pop methods))
1083       (when (and (not (mm-inline-override-p handle))
1084                  (string-match method type))
1085         (setq result t
1086               methods nil)))
1087     result))
1088
1089 (defun mm-inlinable-p (handle &optional type)
1090   "Say whether HANDLE can be displayed inline.
1091 TYPE is the mime-type of the object; it defaults to the one given
1092 in HANDLE."
1093   (unless type (setq type (mm-handle-media-type handle)))
1094   (let ((alist mm-inline-media-tests)
1095         test)
1096     (while alist
1097       (when (string-match (caar alist) type)
1098         (setq test (caddar alist)
1099               alist nil)
1100         (setq test (funcall test handle)))
1101       (pop alist))
1102     test))
1103
1104 (defun mm-inlined-p (handle)
1105   "Say whether the user wants HANDLE to be displayed inline."
1106   (let ((methods mm-inlined-types)
1107         (type (mm-handle-media-type handle))
1108         method result)
1109     (while (setq method (pop methods))
1110       (when (and (not (mm-inline-override-p handle))
1111                  (string-match method type))
1112         (setq result t
1113               methods nil)))
1114     result))
1115
1116 (defun mm-attachment-override-p (handle)
1117   "Say whether HANDLE should have attachment behavior overridden."
1118   (let ((types mm-attachment-override-types)
1119         (type (mm-handle-media-type handle))
1120         ty)
1121     (catch 'found
1122       (while (setq ty (pop types))
1123         (when (and (string-match ty type)
1124                    (mm-inlinable-p handle))
1125           (throw 'found t))))))
1126
1127 (defun mm-inline-override-p (handle)
1128   "Say whether HANDLE should have inline behavior overridden."
1129   (let ((types mm-inline-override-types)
1130         (type (mm-handle-media-type handle))
1131         ty)
1132     (catch 'found
1133       (while (setq ty (pop types))
1134         (when (string-match ty type)
1135           (throw 'found t))))))
1136
1137 (defun mm-automatic-external-display-p (type)
1138   "Return the user-defined method for TYPE."
1139   (let ((methods mm-automatic-external-display)
1140         method result)
1141     (while (setq method (pop methods))
1142       (when (string-match method type)
1143         (setq result t
1144               methods nil)))
1145     result))
1146
1147 (defun mm-destroy-part (handle)
1148   "Destroy the data structures connected to HANDLE."
1149   (when (listp handle)
1150     (mm-remove-part handle)
1151     (when (buffer-live-p (mm-handle-buffer handle))
1152       (kill-buffer (mm-handle-buffer handle)))))
1153
1154 (defun mm-handle-displayed-p (handle)
1155   "Say whether HANDLE is displayed or not."
1156   (mm-handle-undisplayer handle))
1157
1158 ;;;
1159 ;;; Functions for outputting parts
1160 ;;;
1161
1162 (defmacro mm-with-part (handle &rest forms)
1163   "Run FORMS in the temp buffer containing the contents of HANDLE."
1164   ;; The handle-buffer's content is a sequence of bytes, not a sequence of
1165   ;; chars, so the buffer should be unibyte.  It may happen that the
1166   ;; handle-buffer is multibyte for some reason, in which case now is a good
1167   ;; time to adjust it, since we know at this point that it should
1168   ;; be unibyte.
1169   `(let* ((handle ,handle))
1170      (when (and (mm-handle-buffer handle)
1171                 (buffer-name (mm-handle-buffer handle)))
1172        (with-temp-buffer
1173          (mm-disable-multibyte)
1174          (insert-buffer-substring (mm-handle-buffer handle))
1175          (mm-decode-content-transfer-encoding
1176           (mm-handle-encoding handle)
1177           (mm-handle-media-type handle))
1178          ,@forms))))
1179 (put 'mm-with-part 'lisp-indent-function 1)
1180 (put 'mm-with-part 'edebug-form-spec '(body))
1181
1182 (defun mm-get-part (handle &optional no-cache)
1183   "Return the contents of HANDLE as a string.
1184 If NO-CACHE is non-nil, cached contents of a message/external-body part
1185 are ignored."
1186   (if (and (not no-cache)
1187            (equal (mm-handle-media-type handle) "message/external-body"))
1188       (progn
1189         (unless (mm-handle-cache handle)
1190           (mm-extern-cache-contents handle))
1191         (with-current-buffer (mm-handle-buffer (mm-handle-cache handle))
1192           (buffer-string)))
1193     (mm-with-part handle
1194       (buffer-string))))
1195
1196 (defun mm-insert-part (handle &optional no-cache)
1197   "Insert the contents of HANDLE in the current buffer.
1198 If NO-CACHE is non-nil, cached contents of a message/external-body part
1199 are ignored."
1200   (let ((text (cond ((eq (mail-content-type-get (mm-handle-type handle)
1201                                                 'charset)
1202                          'gnus-decoded)
1203                      (with-current-buffer (mm-handle-buffer handle)
1204                        (buffer-string)))
1205                     ((mm-multibyte-p)
1206                      (mm-string-to-multibyte (mm-get-part handle no-cache)))
1207                     (t
1208                      (mm-get-part handle no-cache)))))
1209     (save-restriction
1210       (widen)
1211       (goto-char
1212        (prog1
1213            (point)
1214          (if (and (eq (get-char-property (max (point-min) (1- (point))) 'face)
1215                       'mm-uu-extract)
1216                   (eq (get-char-property 0 'face text) 'mm-uu-extract))
1217              ;; Separate the extracted parts that have the same faces.
1218              (insert "\n" text)
1219            (insert text)))))))
1220
1221 (defun mm-file-name-delete-whitespace (file-name)
1222   "Remove all whitespace characters from FILE-NAME."
1223   (while (string-match "\\s-+" file-name)
1224     (setq file-name (replace-match "" t t file-name)))
1225   file-name)
1226
1227 (defun mm-file-name-trim-whitespace (file-name)
1228   "Remove leading and trailing whitespace characters from FILE-NAME."
1229   (when (string-match "\\`\\s-+" file-name)
1230     (setq file-name (substring file-name (match-end 0))))
1231   (when (string-match "\\s-+\\'" file-name)
1232     (setq file-name (substring file-name 0 (match-beginning 0))))
1233   file-name)
1234
1235 (defun mm-file-name-collapse-whitespace (file-name)
1236   "Collapse multiple whitespace characters in FILE-NAME."
1237   (while (string-match "\\s-\\s-+" file-name)
1238     (setq file-name (replace-match " " t t file-name)))
1239   file-name)
1240
1241 (defun mm-file-name-replace-whitespace (file-name)
1242   "Replace whitespace characters in FILE-NAME with underscores.
1243 Set the option `mm-file-name-replace-whitespace' to any other
1244 string if you do not like underscores."
1245   (let ((s (or mm-file-name-replace-whitespace "_")))
1246     (while (string-match "\\s-" file-name)
1247       (setq file-name (replace-match s t t file-name))))
1248   file-name)
1249
1250 (defun mm-file-name-delete-control (filename)
1251   "Delete control characters from FILENAME."
1252   (gnus-replace-in-string filename "[\x00-\x1f\x7f]" ""))
1253
1254 (defun mm-file-name-delete-gotchas (filename)
1255   "Delete shell gotchas from FILENAME."
1256   (setq filename (gnus-replace-in-string filename "[<>|]" ""))
1257   (gnus-replace-in-string filename "^[.-]+" ""))
1258
1259 (defun mm-save-part (handle &optional prompt)
1260   "Write HANDLE to a file.
1261 PROMPT overrides the default one used to ask user for a file name."
1262   (let ((filename (or (mail-content-type-get
1263                        (mm-handle-disposition handle) 'filename)
1264                       (mail-content-type-get
1265                        (mm-handle-type handle) 'name)))
1266         file)
1267     (when filename
1268       (setq filename (gnus-map-function mm-file-name-rewrite-functions
1269                                         (file-name-nondirectory filename))))
1270     (setq file
1271           (read-file-name
1272            (or prompt
1273                (format "Save MIME part to (default %s): "
1274                        (or filename "")))
1275            (or mm-default-directory default-directory)
1276            (expand-file-name (or filename "")
1277                              (or mm-default-directory default-directory))))
1278     (if (file-directory-p file)
1279         (setq file (expand-file-name filename file))
1280       (setq file (expand-file-name
1281                   file (or mm-default-directory default-directory))))
1282     (setq mm-default-directory (file-name-directory file))
1283     (and (or (not (file-exists-p file))
1284              (yes-or-no-p (format "File %s already exists; overwrite? "
1285                                   file)))
1286          (progn
1287            (mm-save-part-to-file handle file)
1288            file))))
1289
1290 (defun mm-add-meta-html-tag (handle &optional charset force-charset)
1291   "Add meta html tag to specify CHARSET of HANDLE in the current buffer.
1292 CHARSET defaults to the one HANDLE specifies.  Existing meta tag that
1293 specifies charset will not be modified unless FORCE-CHARSET is non-nil.
1294 Return t if meta tag is added or replaced."
1295   (when (equal (mm-handle-media-type handle) "text/html")
1296     (when (or charset
1297               (setq charset (mail-content-type-get (mm-handle-type handle)
1298                                                    'charset)))
1299       (setq charset (format "\
1300 <meta http-equiv=\"Content-Type\" content=\"text/html; charset=%s\">" charset))
1301       (let ((case-fold-search t))
1302         (goto-char (point-min))
1303         (if (re-search-forward "\
1304 <meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']\
1305 text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+\\)\\)?[\"'][^>]*>" nil t)
1306             (if (and (not force-charset)
1307                      (match-beginning 2)
1308                      (string-match "\\`html\\'" (match-string 1)))
1309                 ;; Don't modify existing meta tag.
1310                 nil
1311               ;; Replace it with the one specifying charset.
1312               (replace-match charset)
1313               t)
1314           (if (re-search-forward "<head>\\s-*" nil t)
1315               (insert charset "\n")
1316             (re-search-forward "<html\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t)
1317             (insert "<head>\n" charset "\n</head>\n"))
1318           t)))))
1319
1320 (defun mm-save-part-to-file (handle file)
1321   (mm-with-unibyte-buffer
1322     (mm-insert-part handle)
1323     (mm-add-meta-html-tag handle)
1324     (let ((current-file-modes (default-file-modes)))
1325       (set-default-file-modes mm-attachment-file-modes)
1326       (unwind-protect
1327           ;; Don't re-compress .gz & al.  Arguably we should make
1328           ;; `file-name-handler-alist' nil, but that would chop
1329           ;; ange-ftp, which is reasonable to use here.
1330           (mm-write-region (point-min) (point-max) file nil nil nil 'binary t)
1331         (set-default-file-modes current-file-modes)))))
1332
1333 (defun mm-pipe-part (handle &optional cmd)
1334   "Pipe HANDLE to a process.
1335 Use CMD as the process."
1336   (let ((name (mail-content-type-get (mm-handle-type handle) 'name))
1337         (command (or cmd
1338                      (gnus-read-shell-command
1339                       "Shell command on MIME part: " mm-last-shell-command))))
1340     (mm-with-unibyte-buffer
1341       (mm-insert-part handle)
1342       (mm-add-meta-html-tag handle)
1343       (let ((coding-system-for-write 'binary))
1344         (shell-command-on-region (point-min) (point-max) command nil)))))
1345
1346 (autoload 'gnus-completing-read "gnus-util")
1347
1348 (defun mm-interactively-view-part (handle)
1349   "Display HANDLE using METHOD."
1350   (let* ((type (mm-handle-media-type handle))
1351          (methods
1352           (mapcar (lambda (i) (cdr (assoc 'viewer i)))
1353                   (mailcap-mime-info type 'all)))
1354          (method (let ((minibuffer-local-completion-map
1355                         mm-viewer-completion-map))
1356                    (completing-read "Viewer: " methods))))
1357     (when (string= method "")
1358       (error "No method given"))
1359     (if (string-match "^[^% \t]+$" method)
1360         (setq method (concat method " %s")))
1361     (mm-display-external handle method)))
1362
1363 (defun mm-preferred-alternative (handles &optional preferred)
1364   "Say which of HANDLES are preferred."
1365   (let ((prec (if preferred (list preferred)
1366                 (mm-preferred-alternative-precedence handles)))
1367         p h result type handle)
1368     (while (setq p (pop prec))
1369       (setq h handles)
1370       (while h
1371         (setq handle (car h))
1372         (setq type (mm-handle-media-type handle))
1373         (when (and (equal p type)
1374                    (mm-automatic-display-p handle)
1375                    (or (stringp (car handle))
1376                        (not (mm-handle-disposition handle))
1377                        (equal (car (mm-handle-disposition handle))
1378                               "inline")))
1379           (setq result handle
1380                 h nil
1381                 prec nil))
1382         (pop h)))
1383     result))
1384
1385 (defun mm-preferred-alternative-precedence (handles)
1386   "Return the precedence based on HANDLES and `mm-discouraged-alternatives'."
1387   (setq handles (reverse handles))
1388   (dolist (disc (reverse mm-discouraged-alternatives))
1389     (dolist (handle (copy-sequence handles))
1390       (when (string-match disc (mm-handle-media-type handle))
1391         (setq handles (nconc (delete handle handles) (list handle))))))
1392   ;; Remove empty parts.
1393   (dolist (handle (copy-sequence handles))
1394     (when (and (bufferp (mm-handle-buffer handle))
1395                (not (with-current-buffer (mm-handle-buffer handle)
1396                       (goto-char (point-min))
1397                       (re-search-forward "[^ \t\n]" nil t))))
1398       (setq handles (nconc (delete handle handles) (list handle)))))
1399   (mapcar #'mm-handle-media-type handles))
1400
1401 (defun mm-get-content-id (id)
1402   "Return the handle(s) referred to by ID."
1403   (cdr (assoc id mm-content-id-alist)))
1404
1405 (defconst mm-image-type-regexps
1406   '(("/\\*.*XPM.\\*/" . xpm)
1407     ("P[1-6]" . pbm)
1408     ("GIF8" . gif)
1409     ("\377\330" . jpeg)
1410     ("\211PNG\r\n" . png)
1411     ("#define" . xbm)
1412     ("\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff)
1413     ("%!PS" . postscript))
1414   "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types.
1415 When the first bytes of an image file match REGEXP, it is assumed to
1416 be of image type IMAGE-TYPE.")
1417
1418 ;; Steal from image.el. image-type-from-data suffers multi-line matching bug.
1419 (defun mm-image-type-from-buffer ()
1420   "Determine the image type from data in the current buffer.
1421 Value is a symbol specifying the image type or nil if type cannot
1422 be determined."
1423   (let ((types mm-image-type-regexps)
1424         type)
1425     (goto-char (point-min))
1426     (while (and types (null type))
1427       (let ((regexp (car (car types)))
1428             (image-type (cdr (car types))))
1429         (when (looking-at regexp)
1430           (setq type image-type))
1431         (setq types (cdr types))))
1432     type))
1433
1434 (defun mm-get-image (handle)
1435   "Return an image instance based on HANDLE."
1436   (let ((type (mm-handle-media-subtype handle))
1437         spec)
1438     ;; Allow some common translations.
1439     (setq type
1440           (cond
1441            ((equal type "x-pixmap")
1442             "xpm")
1443            ((equal type "x-xbitmap")
1444             "xbm")
1445            ((equal type "x-portable-bitmap")
1446             "pbm")
1447            (t type)))
1448     (or (mm-handle-cache handle)
1449         (mm-with-unibyte-buffer
1450           (mm-insert-part handle)
1451           (prog1
1452               (setq spec
1453                     (ignore-errors
1454                       ;; Avoid testing `make-glyph' since W3 may define
1455                       ;; a bogus version of it.
1456                       (if (fboundp 'create-image)
1457                           (create-image (buffer-string)
1458                                         (or (mm-image-type-from-buffer)
1459                                             (intern type))
1460                                         'data-p)
1461                         (mm-create-image-xemacs type))))
1462             (mm-handle-set-cache handle spec))))))
1463
1464 (defun mm-create-image-xemacs (type)
1465   (when (featurep 'xemacs)
1466     (cond
1467      ((equal type "xbm")
1468       ;; xbm images require special handling, since
1469       ;; the only way to create glyphs from these
1470       ;; (without a ton of work) is to write them
1471       ;; out to a file, and then create a file
1472       ;; specifier.
1473       (let ((file (mm-make-temp-file
1474                    (expand-file-name "emm" mm-tmp-directory)
1475                    nil ".xbm")))
1476         (unwind-protect
1477             (progn
1478               (write-region (point-min) (point-max) file)
1479               (make-glyph (list (cons 'x file))))
1480           (ignore-errors
1481             (delete-file file)))))
1482      (t
1483       (make-glyph
1484        (vector
1485         (or (mm-image-type-from-buffer)
1486             (intern type))
1487         :data (buffer-string)))))))
1488
1489 (declare-function image-size "image.c" (spec &optional pixels frame))
1490
1491 (defun mm-image-fit-p (handle)
1492   "Say whether the image in HANDLE will fit the current window."
1493   (let ((image (mm-get-image handle)))
1494     (or (not image)
1495         (if (featurep 'xemacs)
1496             ;; XEmacs' glyphs can actually tell us about their width, so
1497             ;; let's be nice and smart about them.
1498             (or mm-inline-large-images
1499                 (and (<= (glyph-width image) (window-pixel-width))
1500                      (<= (glyph-height image) (window-pixel-height))))
1501           (let* ((size (image-size image))
1502                  (w (car size))
1503                  (h (cdr size)))
1504             (or mm-inline-large-images
1505                 (and (<= h (1- (window-height))) ; Don't include mode line.
1506                      (<= w (window-width)))))))))
1507
1508 (defun mm-valid-image-format-p (format)
1509   "Say whether FORMAT can be displayed natively by Emacs."
1510   (cond
1511    ;; Handle XEmacs
1512    ((fboundp 'valid-image-instantiator-format-p)
1513     (valid-image-instantiator-format-p format))
1514    ;; Handle Emacs
1515    ((fboundp 'image-type-available-p)
1516     (and (display-graphic-p)
1517          (image-type-available-p format)))
1518    ;; Nobody else can do images yet.
1519    (t
1520     nil)))
1521
1522 (defun mm-valid-and-fit-image-p (format handle)
1523   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
1524   (and (mm-valid-image-format-p format)
1525        (mm-image-fit-p handle)))
1526
1527 (defun mm-find-part-by-type (handles type &optional notp recursive)
1528   "Search in HANDLES for part with TYPE.
1529 If NOTP, returns first non-matching part.
1530 If RECURSIVE, search recursively."
1531   (let (handle)
1532     (while handles
1533       (if (and recursive (stringp (caar handles)))
1534           (if (setq handle (mm-find-part-by-type (cdar handles) type
1535                                                  notp recursive))
1536               (setq handles nil))
1537         (if (if notp
1538                 (not (equal (mm-handle-media-type (car handles)) type))
1539               (equal (mm-handle-media-type (car handles)) type))
1540             (setq handle (car handles)
1541                   handles nil)))
1542       (setq handles (cdr handles)))
1543     handle))
1544
1545 (defun mm-find-raw-part-by-type (ctl type &optional notp)
1546   (goto-char (point-min))
1547   (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl
1548                                                                    'boundary)))
1549          (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$"))
1550          start
1551          (end (save-excursion
1552                 (goto-char (point-max))
1553                 (if (re-search-backward close-delimiter nil t)
1554                     (match-beginning 0)
1555                   (point-max))))
1556          result)
1557     (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$"))
1558     (while (and (not result)
1559                 (re-search-forward boundary end t))
1560       (goto-char (match-beginning 0))
1561       (when start
1562         (save-excursion
1563           (save-restriction
1564             (narrow-to-region start (1- (point)))
1565             (when (let* ((ct (mail-fetch-field "content-type"))
1566                          (ctl (and ct (mail-header-parse-content-type ct))))
1567                     (if notp
1568                         (not (equal (car ctl) type))
1569                       (equal (car ctl) type)))
1570               (setq result (buffer-string))))))
1571       (forward-line 1)
1572       (setq start (point)))
1573     (when (and (not result) start)
1574       (save-excursion
1575         (save-restriction
1576           (narrow-to-region start end)
1577           (when (let* ((ct (mail-fetch-field "content-type"))
1578                        (ctl (and ct (mail-header-parse-content-type ct))))
1579                   (if notp
1580                       (not (equal (car ctl) type))
1581                     (equal (car ctl) type)))
1582             (setq result (buffer-string))))))
1583     result))
1584
1585 (defvar mm-security-handle nil)
1586
1587 (defsubst mm-set-handle-multipart-parameter (handle parameter value)
1588   ;; HANDLE could be a CTL.
1589   (when handle
1590     (put-text-property 0 (length (car handle)) parameter value
1591                        (car handle))))
1592
1593 (autoload 'mm-view-pkcs7 "mm-view")
1594
1595 (defun mm-possibly-verify-or-decrypt (parts ctl &optional from)
1596   (let ((type (car ctl))
1597         (subtype (cadr (split-string (car ctl) "/")))
1598         (mm-security-handle ctl) ;; (car CTL) is the type.
1599         protocol func functest)
1600     (cond
1601      ((or (equal type "application/x-pkcs7-mime")
1602           (equal type "application/pkcs7-mime"))
1603       (with-temp-buffer
1604         (when (and (cond
1605                     ((eq mm-decrypt-option 'never) nil)
1606                     ((eq mm-decrypt-option 'always) t)
1607                     ((eq mm-decrypt-option 'known) t)
1608                     (t (y-or-n-p
1609                         (format "Decrypt (S/MIME) part? "))))
1610                    (mm-view-pkcs7 parts from))
1611           (setq parts (mm-dissect-buffer t)))))
1612      ((equal subtype "signed")
1613       (unless (and (setq protocol
1614                          (mm-handle-multipart-ctl-parameter ctl 'protocol))
1615                    (not (equal protocol "multipart/mixed")))
1616         ;; The message is broken or draft-ietf-openpgp-multsig-01.
1617         (let ((protocols mm-verify-function-alist))
1618           (while protocols
1619             (if (and (or (not (setq functest (nth 3 (car protocols))))
1620                          (funcall functest parts ctl))
1621                      (mm-find-part-by-type parts (caar protocols) nil t))
1622                 (setq protocol (caar protocols)
1623                       protocols nil)
1624               (setq protocols (cdr protocols))))))
1625       (setq func (nth 1 (assoc protocol mm-verify-function-alist)))
1626       (when (cond
1627              ((eq mm-verify-option 'never) nil)
1628              ((eq mm-verify-option 'always) t)
1629              ((eq mm-verify-option 'known)
1630               (and func
1631                    (or (not (setq functest
1632                                   (nth 3 (assoc protocol
1633                                                 mm-verify-function-alist))))
1634                        (funcall functest parts ctl))))
1635              (t
1636               (y-or-n-p
1637                (format "Verify signed (%s) part? "
1638                        (or (nth 2 (assoc protocol mm-verify-function-alist))
1639                            (format "protocol=%s" protocol))))))
1640         (save-excursion
1641           (if func
1642               (setq parts (funcall func parts ctl))
1643             (mm-set-handle-multipart-parameter
1644              mm-security-handle 'gnus-details
1645              (format "Unknown sign protocol (%s)" protocol))))))
1646      ((equal subtype "encrypted")
1647       (unless (setq protocol
1648                     (mm-handle-multipart-ctl-parameter ctl 'protocol))
1649         ;; The message is broken.
1650         (let ((parts parts))
1651           (while parts
1652             (if (assoc (mm-handle-media-type (car parts))
1653                        mm-decrypt-function-alist)
1654                 (setq protocol (mm-handle-media-type (car parts))
1655                       parts nil)
1656               (setq parts (cdr parts))))))
1657       (setq func (nth 1 (assoc protocol mm-decrypt-function-alist)))
1658       (when (cond
1659              ((eq mm-decrypt-option 'never) nil)
1660              ((eq mm-decrypt-option 'always) t)
1661              ((eq mm-decrypt-option 'known)
1662               (and func
1663                    (or (not (setq functest
1664                                   (nth 3 (assoc protocol
1665                                                 mm-decrypt-function-alist))))
1666                        (funcall functest parts ctl))))
1667              (t
1668               (y-or-n-p
1669                (format "Decrypt (%s) part? "
1670                        (or (nth 2 (assoc protocol mm-decrypt-function-alist))
1671                            (format "protocol=%s" protocol))))))
1672         (save-excursion
1673           (if func
1674               (setq parts (funcall func parts ctl))
1675             (mm-set-handle-multipart-parameter
1676              mm-security-handle 'gnus-details
1677              (format "Unknown encrypt protocol (%s)" protocol))))))
1678      (t nil))
1679     parts))
1680
1681 (defun mm-multiple-handles (handles)
1682   (and (listp handles)
1683        (> (length handles) 1)
1684        (or (listp (car handles))
1685            (stringp (car handles)))))
1686
1687 (defun mm-complicated-handles (handles)
1688   (and (listp (car handles))
1689        (> (length handles) 1)))
1690
1691 (defun mm-merge-handles (handles1 handles2)
1692   (append
1693    (if (listp (car handles1))
1694        handles1
1695      (list handles1))
1696    (if (listp (car handles2))
1697        handles2
1698      (list handles2))))
1699
1700 (defun mm-readable-p (handle)
1701   "Say whether the content of HANDLE is readable."
1702   (and (< (with-current-buffer (mm-handle-buffer handle)
1703             (buffer-size)) 10000)
1704        (mm-with-unibyte-buffer
1705          (mm-insert-part handle)
1706          (and (eq (mm-body-7-or-8) '7bit)
1707               (not (mm-long-lines-p 76))))))
1708
1709 (declare-function libxml-parse-html-region "xml.c"
1710                   (start end &optional base-url))
1711 (declare-function shr-insert-document "shr" (dom))
1712 (defvar shr-blocked-images)
1713 (defvar gnus-inhibit-images)
1714 (autoload 'gnus-blocked-images "gnus-art")
1715
1716 (defun mm-shr (handle)
1717   ;; Require since we bind its variables.
1718   (require 'shr)
1719   (let ((article-buffer (current-buffer))
1720         (shr-content-function (lambda (id)
1721                                 (let ((handle (mm-get-content-id id)))
1722                                   (when handle
1723                                     (mm-with-part handle
1724                                       (buffer-string))))))
1725         shr-inhibit-images shr-blocked-images charset char)
1726     (if (and (boundp 'gnus-summary-buffer)
1727              (bufferp gnus-summary-buffer)
1728              (buffer-name gnus-summary-buffer))
1729         (with-current-buffer gnus-summary-buffer
1730           (setq shr-inhibit-images gnus-inhibit-images
1731                 shr-blocked-images (gnus-blocked-images)))
1732       (setq shr-inhibit-images gnus-inhibit-images
1733             shr-blocked-images (gnus-blocked-images)))
1734     (unless handle
1735       (setq handle (mm-dissect-buffer t)))
1736     (setq charset (mail-content-type-get (mm-handle-type handle) 'charset))
1737     (save-restriction
1738       (narrow-to-region (point) (point))
1739       (shr-insert-document
1740        (mm-with-part handle
1741          (insert (prog1
1742                      (if (and charset
1743                               (setq charset
1744                                     (mm-charset-to-coding-system charset))
1745                               (not (eq charset 'ascii)))
1746                          (mm-decode-coding-string (buffer-string) charset)
1747                        (mm-string-as-multibyte (buffer-string)))
1748                    (erase-buffer)
1749                    (mm-enable-multibyte)))
1750          (goto-char (point-min))
1751          (setq case-fold-search t)
1752          (while (re-search-forward
1753                  "&#\\(?:x\\([89][0-9a-f]\\)\\|\\(1[2-5][0-9]\\)\\);" nil t)
1754            (when (setq char
1755                        (cdr (assq (if (match-beginning 1)
1756                                       (string-to-number (match-string 1) 16)
1757                                     (string-to-number (match-string 2)))
1758                                   mm-extra-numeric-entities)))
1759              (replace-match (char-to-string char))))
1760          (libxml-parse-html-region (point-min) (point-max))))
1761       (mm-handle-set-undisplayer
1762        handle
1763        `(lambda ()
1764           (let ((inhibit-read-only t))
1765             (delete-region ,(point-min-marker)
1766                            ,(point-max-marker))))))))
1767
1768 (defun mm-handle-filename (handle)
1769   "Return filename of HANDLE if any."
1770   (or (mail-content-type-get (mm-handle-type handle)
1771                              'name)
1772       (mail-content-type-get (mm-handle-disposition handle)
1773                              'filename)))
1774
1775 (provide 'mm-decode)
1776
1777 ;;; mm-decode.el ends here