lisp/gnus/mm-decode.el

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