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

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