lisp/gnus/mm-decode.el

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