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   :type '(repeat string)
 340   :group 'mime-display)
 341
 342 (defcustom mm-tmp-directory
 343   (if (fboundp 'temp-directory)
 344       (temp-directory)
 345     (if (boundp 'temporary-file-directory)
 346         temporary-file-directory
 347       "/tmp/"))
 348   "Where mm will store its temporary files."
 349   :type 'directory
 350   :group 'mime-display)
 351
 352 (defcustom mm-inline-large-images nil
 353   "If non-nil, then all images fit in the buffer."
 354   :type 'boolean
 355   :group 'mime-display)
 356
 357 (defvar mm-file-name-rewrite-functions
 358   '(mm-file-name-delete-control mm-file-name-delete-gotchas)
 359   "*List of functions used for rewriting file names of MIME parts.
 360 Each function takes a file name as input and returns a file name.
 361
 362 Ready-made functions include
 363 `mm-file-name-delete-control'
 364 `mm-file-name-delete-gotchas'
 365 `mm-file-name-delete-whitespace',
 366 `mm-file-name-trim-whitespace',
 367 `mm-file-name-collapse-whitespace',
 368 `mm-file-name-replace-whitespace',
 369 `capitalize', `downcase', `upcase', and
 370 `upcase-initials'.")
 371
 372 (defvar mm-path-name-rewrite-functions nil
 373   "*List of functions for rewriting the full file names of MIME parts.
 374 This is used when viewing parts externally, and is meant for
 375 transforming the absolute name so that non-compliant programs can find
 376 the file where it's saved.
 377
 378 Each function takes a file name as input and returns a file name.")
 379
 380 (defvar mm-file-name-replace-whitespace nil
 381   "String used for replacing whitespace characters; default is `\"_\"'.")
 382
 383 (defcustom mm-default-directory nil
 384   "The default directory where mm will save files.
 385 If not set, `default-directory' will be used."
 386   :type '(choice directory (const :tag "Default" nil))
 387   :group 'mime-display)
 388
 389 (defcustom mm-attachment-file-modes 384
 390   "Set the mode bits of saved attachments to this integer."
 391   :version "22.1"
 392   :type 'integer
 393   :group 'mime-display)
 394
 395 (defcustom mm-external-terminal-program "xterm"
 396   "The program to start an external terminal."
 397   :version "22.1"
 398   :type 'string
 399   :group 'mime-display)
 400
 401 ;;; Internal variables.
 402
 403 (defvar mm-last-shell-command "")
 404 (defvar mm-content-id-alist nil)
 405 (defvar mm-postponed-undisplay-list nil)
 406
 407 ;; According to RFC2046, in particular, in a digest, the default
 408 ;; Content-Type value for a body part is changed from "text/plain" to
 409 ;; "message/rfc822".
 410 (defvar mm-dissect-default-type "text/plain")
 411
 412 (autoload 'mml2015-verify "mml2015")
 413 (autoload 'mml2015-verify-test "mml2015")
 414 (autoload 'mml-smime-verify "mml-smime")
 415 (autoload 'mml-smime-verify-test "mml-smime")
 416
 417 (defvar mm-verify-function-alist
 418   '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test)
 419     ("application/x-gnus-pgp-signature" mm-uu-pgp-signed-extract-1 "PGP"
 420      mm-uu-pgp-signed-test)
 421     ("application/pkcs7-signature" mml-smime-verify "S/MIME"
 422      mml-smime-verify-test)
 423     ("application/x-pkcs7-signature" mml-smime-verify "S/MIME"
 424      mml-smime-verify-test)))
 425
 426 (defcustom mm-verify-option 'never
 427   "Option of verifying signed parts.
 428 `never', not verify; `always', always verify;
 429 `known', only verify known protocols.  Otherwise, ask user."
 430   :version "22.1"
 431   :type '(choice (item always)
 432                  (item never)
 433                  (item :tag "only known protocols" known)
 434                  (item :tag "ask" nil))
 435   :group 'mime-security)
 436
 437 (autoload 'mml2015-decrypt "mml2015")
 438 (autoload 'mml2015-decrypt-test "mml2015")
 439
 440 (defvar mm-decrypt-function-alist
 441   '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test)
 442     ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP"
 443      mm-uu-pgp-encrypted-test)))
 444
 445 (defcustom mm-decrypt-option nil
 446   "Option of decrypting encrypted parts.
 447 `never', not decrypt; `always', always decrypt;
 448 `known', only decrypt known protocols.  Otherwise, ask user."
 449   :version "22.1"
 450   :type '(choice (item always)
 451                  (item never)
 452                  (item :tag "only known protocols" known)
 453                  (item :tag "ask" nil))
 454   :group 'mime-security)
 455
 456 (defvar mm-viewer-completion-map
 457   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
 458     (set-keymap-parent map minibuffer-local-completion-map)
 459     ;; Should we bind other key to minibuffer-complete-word?
 460     (define-key map " " 'self-insert-command)
 461     map)
 462   "Keymap for input viewer with completion.")
 463
 464 (defvar mm-viewer-completion-map
 465   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
 466     (set-keymap-parent map minibuffer-local-completion-map)
 467     ;; Should we bind other key to minibuffer-complete-word?
 468     (define-key map " " 'self-insert-command)
 469     map)
 470   "Keymap for input viewer with completion.")
 471
 472 ;;; The functions.
 473
 474 (defun mm-alist-to-plist (alist)
 475   "Convert association list ALIST into the equivalent property-list form.
 476 The plist is returned.  This converts from
 477
 478 \((a . 1) (b . 2) (c . 3))
 479
 480 into
 481
 482 \(a 1 b 2 c 3)
 483
 484 The original alist is not modified.  See also `destructive-alist-to-plist'."
 485   (let (plist)
 486     (while alist
 487       (let ((el (car alist)))
 488         (setq plist (cons (cdr el) (cons (car el) plist))))
 489       (setq alist (cdr alist)))
 490     (nreverse plist)))
 491
 492 (defun mm-keep-viewer-alive-p (handle)
 493   "Say whether external viewer for HANDLE should stay alive."
 494   (let ((types mm-keep-viewer-alive-types)
 495         (type (mm-handle-media-type handle))
 496         ty)
 497     (catch 'found
 498       (while (setq ty (pop types))
 499         (when (string-match ty type)
 500           (throw 'found t))))))
 501
 502 (defun mm-handle-set-external-undisplayer (handle function)
 503   "Set the undisplayer for HANDLE to FUNCTION.
 504 Postpone undisplaying of viewers for types in
 505 `mm-keep-viewer-alive-types'."
 506   (if (mm-keep-viewer-alive-p handle)
 507       (let ((new-handle (copy-sequence handle)))
 508         (mm-handle-set-undisplayer new-handle function)
 509         (mm-handle-set-undisplayer handle nil)
 510         (push new-handle mm-postponed-undisplay-list))
 511     (mm-handle-set-undisplayer handle function)))
 512
 513 (defun mm-destroy-postponed-undisplay-list ()
 514   (when mm-postponed-undisplay-list
 515     (message "Destroying external MIME viewers")
 516     (mm-destroy-parts mm-postponed-undisplay-list)))
 517
 518 (defun mm-dissect-buffer (&optional no-strict-mime loose-mime from)
 519   "Dissect the current buffer and return a list of MIME handles."
 520   (save-excursion
 521     (let (ct ctl type subtype cte cd description id result)
 522       (save-restriction
 523         (mail-narrow-to-head)
 524         (when (or no-strict-mime
 525                   loose-mime
 526                   (mail-fetch-field "mime-version"))
 527           (setq ct (mail-fetch-field "content-type")
 528                 ctl (ignore-errors (mail-header-parse-content-type ct))
 529                 cte (mail-fetch-field "content-transfer-encoding")
 530                 cd (mail-fetch-field "content-disposition")
 531                 description (mail-fetch-field "content-description")
 532                 id (mail-fetch-field "content-id"))
 533           (unless from
 534                 (setq from (mail-fetch-field "from")))
 535           ;; FIXME: In some circumstances, this code is running within
 536           ;; an unibyte macro.  mail-extract-address-components
 537           ;; creates unibyte buffers. This `if', though not a perfect
 538           ;; solution, avoids most of them.
 539           (if from
 540               (setq from (cadr (mail-extract-address-components from))))))
 541       (if (or (not ctl)
 542               (not (string-match "/" (car ctl))))
 543           (mm-dissect-singlepart
 544            (list mm-dissect-default-type)
 545            (and cte (intern (downcase (mail-header-strip cte))))
 546            no-strict-mime
 547            (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
 548            description)
 549         (setq type (split-string (car ctl) "/"))
 550         (setq subtype (cadr type)
 551               type (pop type))
 552         (setq
 553          result
 554          (cond
 555           ((equal type "multipart")
 556            (let ((mm-dissect-default-type (if (equal subtype "digest")
 557                                               "message/rfc822"
 558                                             "text/plain"))
 559                  (start (cdr (assq 'start (cdr ctl)))))
 560              (add-text-properties 0 (length (car ctl))
 561                                   (mm-alist-to-plist (cdr ctl)) (car ctl))
 562
 563              ;; what really needs to be done here is a way to link a
 564              ;; MIME handle back to it's parent MIME handle (in a multilevel
 565              ;; MIME article).  That would probably require changing
 566              ;; the mm-handle API so we simply store the multipart buffer
 567              ;; name as a text property of the "multipart/whatever" string.
 568              (add-text-properties 0 (length (car ctl))
 569                                   (list 'buffer (mm-copy-to-buffer)
 570                                         'from from
 571                                         'start start)
 572                                   (car ctl))
 573              (cons (car ctl) (mm-dissect-multipart ctl from))))
 574           (t
 575            (mm-possibly-verify-or-decrypt
 576             (mm-dissect-singlepart
 577              ctl
 578              (and cte (intern (downcase (mail-header-strip cte))))
 579              no-strict-mime
 580              (and cd (ignore-errors
 581                        (mail-header-parse-content-disposition cd)))
 582              description id)
 583             ctl))))
 584         (when id
 585           (when (string-match " *<\\(.*\\)> *" id)
 586             (setq id (match-string 1 id)))
 587           (push (cons id result) mm-content-id-alist))
 588         result))))
 589
 590 (defun mm-dissect-singlepart (ctl cte &optional force cdl description id)
 591   (when (or force
 592             (if (equal "text/plain" (car ctl))
 593                 (assoc 'format ctl)
 594               t))
 595     (mm-make-handle
 596      (mm-copy-to-buffer) ctl cte nil cdl description nil id)))
 597
 598 (defun mm-dissect-multipart (ctl from)
 599   (goto-char (point-min))
 600   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 601          (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
 602          start parts
 603          (end (save-excursion
 604                 (goto-char (point-max))
 605                 (if (re-search-backward close-delimiter nil t)
 606                     (match-beginning 0)
 607                   (point-max)))))
 608     (setq boundary (concat (regexp-quote boundary) "[ \t]*$"))
 609     (while (and (< (point) end) (re-search-forward boundary end t))
 610       (goto-char (match-beginning 0))
 611       (when start
 612         (save-excursion
 613           (save-restriction
 614             (narrow-to-region start (point))
 615             (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
 616       (end-of-line 2)
 617       (or (looking-at boundary)
 618           (forward-line 1))
 619       (setq start (point)))
 620     (when (and start (< start end))
 621       (save-excursion
 622         (save-restriction
 623           (narrow-to-region start end)
 624           (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
 625     (mm-possibly-verify-or-decrypt (nreverse parts) ctl)))
 626
 627 (defun mm-copy-to-buffer ()
 628   "Copy the contents of the current buffer to a fresh buffer."
 629   (save-excursion
 630     (let ((obuf (current-buffer))
 631           beg)
 632       (goto-char (point-min))
 633       (search-forward-regexp "^\n" nil t)
 634       (setq beg (point))
 635       (set-buffer
 636        ;; Preserve the data's unibyteness (for url-insert-file-contents).
 637        (let ((default-enable-multibyte-characters (mm-multibyte-p)))
 638          (generate-new-buffer " *mm*")))
 639       (insert-buffer-substring obuf beg)
 640       (current-buffer))))
 641
 642 (defun mm-display-parts (handle &optional no-default)
 643   (if (stringp (car handle))
 644       (mapcar 'mm-display-parts (cdr handle))
 645     (if (bufferp (car handle))
 646         (save-restriction
 647           (narrow-to-region (point) (point))
 648           (mm-display-part handle)
 649           (goto-char (point-max)))
 650       (mapcar 'mm-display-parts handle))))
 651
 652 (defun mm-display-part (handle &optional no-default)
 653   "Display the MIME part represented by HANDLE.
 654 Returns nil if the part is removed; inline if displayed inline;
 655 external if displayed external."
 656   (save-excursion
 657     (mailcap-parse-mailcaps)
 658     (if (mm-handle-displayed-p handle)
 659         (mm-remove-part handle)
 660       (let* ((type (mm-handle-media-type handle))
 661              (method (mailcap-mime-info type))
 662              (filename (or (mail-content-type-get
 663                             (mm-handle-disposition handle) 'filename)
 664                            (mail-content-type-get
 665                             (mm-handle-type handle) 'name)
 666                            "<file>"))
 667              (external mm-enable-external))
 668         (if (and (mm-inlinable-p handle)
 669                  (mm-inlined-p handle))
 670             (progn
 671               (forward-line 1)
 672               (mm-display-inline handle)
 673               'inline)
 674           (when (or method
 675                     (not no-default))
 676             (if (and (not method)
 677                      (equal "text" (car (split-string type))))
 678                 (progn
 679                   (forward-line 1)
 680                   (mm-insert-inline handle (mm-get-part handle))
 681                   'inline)
 682               (if (and method ;; If nil, we always use "save".
 683                        (stringp method) ;; 'mailcap-save-binary-file
 684                        (or (eq mm-enable-external t)
 685                            (and (eq mm-enable-external 'ask)
 686                                 (y-or-n-p
 687                                  (concat
 688                                   "Display part (" type
 689                                   ") using external program"
 690                                   ;; Can non-string method ever happen?
 691                                   (if (stringp method)
 692                                       (concat
 693                                        " \"" (format method filename) "\"")
 694                                     "")
 695                                   "? ")))))
 696                   (setq external t)
 697                 (setq external nil))
 698               (if external
 699                   (mm-display-external
 700                    handle (or method 'mailcap-save-binary-file))
 701                 (mm-display-external
 702                  handle 'mailcap-save-binary-file)))))))))
 703
 704 (defun mm-display-external (handle method)
 705   "Display HANDLE using METHOD."
 706   (let ((outbuf (current-buffer)))
 707     (mm-with-unibyte-buffer
 708       (if (functionp method)
 709           (let ((cur (current-buffer)))
 710             (if (eq method 'mailcap-save-binary-file)
 711                 (progn
 712                   (set-buffer (generate-new-buffer " *mm*"))
 713                   (setq method nil))
 714               (mm-insert-part handle)
 715               (let ((win (get-buffer-window cur t)))
 716                 (when win
 717                   (select-window win)))
 718               (switch-to-buffer (generate-new-buffer " *mm*")))
 719             (buffer-disable-undo)
 720             (mm-set-buffer-file-coding-system mm-binary-coding-system)
 721             (insert-buffer-substring cur)
 722             (goto-char (point-min))
 723             (when method
 724               (message "Viewing with %s" method))
 725             (let ((mm (current-buffer))
 726                   (non-viewer (assq 'non-viewer
 727                                     (mailcap-mime-info
 728                                      (mm-handle-media-type handle) t))))
 729               (unwind-protect
 730                   (if method
 731                       (funcall method)
 732                     (mm-save-part handle))
 733                 (when (and (not non-viewer)
 734                            method)
 735                   (mm-handle-set-undisplayer handle mm)))))
 736         ;; The function is a string to be executed.
 737         (mm-insert-part handle)
 738         (let* ((dir (mm-make-temp-file
 739                      (expand-file-name "emm." mm-tmp-directory) 'dir))
 740                (filename (or
 741                           (mail-content-type-get
 742                            (mm-handle-disposition handle) 'filename)
 743                           (mail-content-type-get
 744                            (mm-handle-type handle) 'name)))
 745                (mime-info (mailcap-mime-info
 746                            (mm-handle-media-type handle) t))
 747                (needsterm (or (assoc "needsterm" mime-info)
 748                               (assoc "needsterminal" mime-info)))
 749                (copiousoutput (assoc "copiousoutput" mime-info))
 750                file buffer)
 751           ;; We create a private sub-directory where we store our files.
 752           (set-file-modes dir 448)
 753           (if filename
 754               (setq file (expand-file-name
 755                           (gnus-map-function mm-file-name-rewrite-functions
 756                                              (file-name-nondirectory filename))
 757                           dir))
 758             (setq file (mm-make-temp-file (expand-file-name "mm." dir)))
 759             (let ((newname
 760                    ;; Use nametemplate (defined in RFC1524) if it is
 761                    ;; specified in mailcap.
 762                    (if (assoc "nametemplate" mime-info)
 763                        (format (assoc "nametemplate" mime-info) file)
 764                      ;; Add a suffix according to `mailcap-mime-extensions'.
 765                      (concat file (car (rassoc (mm-handle-media-type handle)
 766                                                mailcap-mime-extensions))))))
 767               (unless (string-equal file newname)
 768                 (when (file-exists-p file)
 769                   (rename-file file newname))
 770                 (setq file newname))))
 771           (let ((coding-system-for-write mm-binary-coding-system))
 772             (write-region (point-min) (point-max) file nil 'nomesg))
 773           (message "Viewing with %s" method)
 774           (cond
 775            (needsterm
 776             (let ((command (mm-mailcap-command
 777                             method file (mm-handle-type handle))))
 778               (unwind-protect
 779                   (if window-system
 780                       (start-process "*display*" nil
 781                                      mm-external-terminal-program
 782                                      "-e" shell-file-name
 783                                      shell-command-switch command)
 784                     (require 'term)
 785                     (require 'gnus-win)
 786                     (set-buffer
 787                      (setq buffer
 788                            (make-term "display"
 789                                       shell-file-name
 790                                       nil
 791                                       shell-command-switch command)))
 792                     (term-mode)
 793                     (term-char-mode)
 794                     (set-process-sentinel
 795                      (get-buffer-process buffer)
 796                      `(lambda (process state)
 797                         (if (eq 'exit (process-status process))
 798                             (gnus-configure-windows
 799                              ',gnus-current-window-configuration))))
 800                     (gnus-configure-windows 'display-term))
 801                 (mm-handle-set-external-undisplayer handle (cons file buffer)))
 802               (message "Displaying %s..." command))
 803             'external)
 804            (copiousoutput
 805             (with-current-buffer outbuf
 806               (forward-line 1)
 807               (mm-insert-inline
 808                handle
 809                (unwind-protect
 810                    (progn
 811                      (call-process shell-file-name nil
 812                                    (setq buffer
 813                                          (generate-new-buffer " *mm*"))
 814                                    nil
 815                                    shell-command-switch
 816                                    (mm-mailcap-command
 817                                     method file (mm-handle-type handle)))
 818                      (if (buffer-live-p buffer)
 819                          (with-current-buffer buffer
 820                            (buffer-string))))
 821                  (progn
 822                    (ignore-errors (delete-file file))
 823                    (ignore-errors (delete-directory
 824                                    (file-name-directory file)))
 825                    (ignore-errors (kill-buffer buffer))))))
 826             'inline)
 827            (t
 828             ;; Deleting the temp file should be postponed for some wrappers,
 829             ;; shell scripts, and so on, which might exit right after having
 830             ;; started a viewer command as a background job.
 831             (let ((command (mm-mailcap-command
 832                             method file (mm-handle-type handle))))
 833               (unwind-protect
 834                   (progn
 835                     (start-process "*display*"
 836                                    (setq buffer
 837                                          (generate-new-buffer " *mm*"))
 838                                    shell-file-name
 839                                    shell-command-switch command)
 840                     (set-process-sentinel
 841                      (get-buffer-process buffer)
 842                      (lexical-let ;; Don't use `let'.
 843                          ;; Function used to remove temp file and directory.
 844                          ((fn `(lambda nil
 845                                  ;; Don't use `ignore-errors'.
 846                                  (condition-case nil
 847                                      (delete-file ,file)
 848                                    (error))
 849                                  (condition-case nil
 850                                      (delete-directory
 851                                       ,(file-name-directory file))
 852                                    (error))))
 853                           ;; Form uses to kill the process buffer and
 854                           ;; remove the undisplayer.
 855                           (fm `(progn
 856                                  (kill-buffer ,buffer)
 857                                  ,(macroexpand
 858                                    (list 'mm-handle-set-undisplayer
 859                                          (list 'quote handle)
 860                                          nil))))
 861                           ;; Message to be issued when the process exits.
 862                           (done (format "Displaying %s...done" command))
 863                           ;; In particular, the timer object (which is
 864                           ;; a vector in Emacs but is a list in XEmacs)
 865                           ;; requires that it is lexically scoped.
 866                           (timer (run-at-time 2.0 nil 'ignore)))
 867                        (lambda (process state)
 868                          (when (eq 'exit (process-status process))
 869                            (if (memq timer timer-list)
 870                                (timer-set-function timer fn)
 871                              (funcall fn))
 872                            (ignore-errors (eval fm))
 873                            (message "%s" done))))))
 874                 (mm-handle-set-external-undisplayer
 875                  handle (cons file buffer)))
 876               (message "Displaying %s..." command))
 877             'external)))))))
 878
 879 (defun mm-mailcap-command (method file type-list)
 880   (let ((ctl (cdr type-list))
 881         (beg 0)
 882         (uses-stdin t)
 883         out sub total)
 884     (while (string-match "%{\\([^}]+\\)}\\|'%s'\\|\"%s\"\\|%s\\|%t\\|%%"
 885                          method beg)
 886       (push (substring method beg (match-beginning 0)) out)
 887       (setq beg (match-end 0)
 888             total (match-string 0 method)
 889             sub (match-string 1 method))
 890       (cond
 891        ((string= total "%%")
 892         (push "%" out))
 893        ((or (string= total "%s")
 894             ;; We do our own quoting.
 895             (string= total "'%s'")
 896             (string= total "\"%s\""))
 897         (setq uses-stdin nil)
 898         (push (shell-quote-argument
 899                (gnus-map-function mm-path-name-rewrite-functions file)) out))
 900        ((string= total "%t")
 901         (push (shell-quote-argument (car type-list)) out))
 902        (t
 903         (push (shell-quote-argument (or (cdr (assq (intern sub) ctl)) "")) out))))
 904     (push (substring method beg (length method)) out)
 905     (when uses-stdin
 906       (push "<" out)
 907       (push (shell-quote-argument
 908              (gnus-map-function mm-path-name-rewrite-functions file))
 909             out))
 910     (mapconcat 'identity (nreverse out) "")))
 911
 912 (defun mm-remove-parts (handles)
 913   "Remove the displayed MIME parts represented by HANDLES."
 914   (if (and (listp handles)
 915            (bufferp (car handles)))
 916       (mm-remove-part handles)
 917     (let (handle)
 918       (while (setq handle (pop handles))
 919         (cond
 920          ((stringp handle)
 921           (when (buffer-live-p (get-text-property 0 'buffer handle))
 922             (kill-buffer (get-text-property 0 'buffer handle))))
 923          ((and (listp handle)
 924                (stringp (car handle)))
 925           (mm-remove-parts (cdr handle)))
 926          (t
 927           (mm-remove-part handle)))))))
 928
 929 (defun mm-destroy-parts (handles)
 930   "Remove the displayed MIME parts represented by HANDLES."
 931   (if (and (listp handles)
 932            (bufferp (car handles)))
 933       (mm-destroy-part handles)
 934     (let (handle)
 935       (while (setq handle (pop handles))
 936         (cond
 937          ((stringp handle)
 938           (when (buffer-live-p (get-text-property 0 'buffer handle))
 939             (kill-buffer (get-text-property 0 'buffer handle))))
 940          ((and (listp handle)
 941                (stringp (car handle)))
 942           (mm-destroy-parts handle))
 943          (t
 944           (mm-destroy-part handle)))))))
 945
 946 (defun mm-remove-part (handle)
 947   "Remove the displayed MIME part represented by HANDLE."
 948   (when (listp handle)
 949     (let ((object (mm-handle-undisplayer handle)))
 950       (ignore-errors
 951         (cond
 952          ;; Internally displayed part.
 953          ((mm-annotationp object)
 954           (delete-annotation object))
 955          ((or (functionp object)
 956               (and (listp object)
 957                    (eq (car object) 'lambda)))
 958           (funcall object))
 959          ;; Externally displayed part.
 960          ((consp object)
 961           (condition-case ()
 962               (while (get-buffer-process (cdr object))
 963                 (interrupt-process (get-buffer-process (cdr object)))
 964                 (message "Waiting for external displayer to die...")
 965                 (sit-for 1))
 966             (quit)
 967             (error))
 968           (ignore-errors (and (cdr object) (kill-buffer (cdr object))))
 969           (message "Waiting for external displayer to die...done")
 970           (ignore-errors (delete-file (car object)))
 971           (ignore-errors (delete-directory (file-name-directory
 972                                             (car object)))))
 973          ((bufferp object)
 974           (when (buffer-live-p object)
 975             (kill-buffer object)))))
 976       (mm-handle-set-undisplayer handle nil))))
 977
 978 (defun mm-display-inline (handle)
 979   (let* ((type (mm-handle-media-type handle))
 980          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
 981     (funcall function handle)
 982     (goto-char (point-min))))
 983
 984 (defun mm-assoc-string-match (alist type)
 985   (dolist (elem alist)
 986     (when (string-match (car elem) type)
 987       (return elem))))
 988
 989 (defun mm-automatic-display-p (handle)
 990   "Say whether the user wants HANDLE to be displayed automatically."
 991   (let ((methods mm-automatic-display)
 992         (type (mm-handle-media-type handle))
 993         method result)
 994     (while (setq method (pop methods))
 995       (when (and (not (mm-inline-override-p handle))
 996                  (string-match method type))
 997         (setq result t
 998               methods nil)))
 999     result))
1000
1001 (defun mm-inlinable-p (handle)
1002   "Say whether HANDLE can be displayed inline."
1003   (let ((alist mm-inline-media-tests)
1004         (type (mm-handle-media-type handle))
1005         test)
1006     (while alist
1007       (when (string-match (caar alist) type)
1008         (setq test (caddar alist)
1009               alist nil)
1010         (setq test (funcall test handle)))
1011       (pop alist))
1012     test))
1013
1014 (defun mm-inlined-p (handle)
1015   "Say whether the user wants HANDLE to be displayed inline."
1016   (let ((methods mm-inlined-types)
1017         (type (mm-handle-media-type handle))
1018         method result)
1019     (while (setq method (pop methods))
1020       (when (and (not (mm-inline-override-p handle))
1021                  (string-match method type))
1022         (setq result t
1023               methods nil)))
1024     result))
1025
1026 (defun mm-attachment-override-p (handle)
1027   "Say whether HANDLE should have attachment behavior overridden."
1028   (let ((types mm-attachment-override-types)
1029         (type (mm-handle-media-type handle))
1030         ty)
1031     (catch 'found
1032       (while (setq ty (pop types))
1033         (when (and (string-match ty type)
1034                    (mm-inlinable-p handle))
1035           (throw 'found t))))))
1036
1037 (defun mm-inline-override-p (handle)
1038   "Say whether HANDLE should have inline behavior overridden."
1039   (let ((types mm-inline-override-types)
1040         (type (mm-handle-media-type handle))
1041         ty)
1042     (catch 'found
1043       (while (setq ty (pop types))
1044         (when (string-match ty type)
1045           (throw 'found t))))))
1046
1047 (defun mm-automatic-external-display-p (type)
1048   "Return the user-defined method for TYPE."
1049   (let ((methods mm-automatic-external-display)
1050         method result)
1051     (while (setq method (pop methods))
1052       (when (string-match method type)
1053         (setq result t
1054               methods nil)))
1055     result))
1056
1057 (defun mm-destroy-part (handle)
1058   "Destroy the data structures connected to HANDLE."
1059   (when (listp handle)
1060     (mm-remove-part handle)
1061     (when (buffer-live-p (mm-handle-buffer handle))
1062       (kill-buffer (mm-handle-buffer handle)))))
1063
1064 (defun mm-handle-displayed-p (handle)
1065   "Say whether HANDLE is displayed or not."
1066   (mm-handle-undisplayer handle))
1067
1068 ;;;
1069 ;;; Functions for outputting parts
1070 ;;;
1071
1072 (defun mm-get-part (handle)
1073   "Return the contents of HANDLE as a string."
1074   (mm-with-unibyte-buffer
1075     (insert (with-current-buffer (mm-handle-buffer handle)
1076               (mm-with-unibyte-current-buffer
1077                 (buffer-string))))
1078     (mm-decode-content-transfer-encoding
1079      (mm-handle-encoding handle)
1080      (mm-handle-media-type handle))
1081     (buffer-string)))
1082
1083 (defun mm-insert-part (handle)
1084   "Insert the contents of HANDLE in the current buffer."
1085   (save-excursion
1086     (insert
1087      (cond ((eq (mail-content-type-get (mm-handle-type handle) 'charset)
1088                 'gnus-decoded)
1089             (with-current-buffer (mm-handle-buffer handle)
1090               (buffer-string)))
1091            ((mm-multibyte-p)
1092             (mm-string-as-multibyte (mm-get-part handle)))
1093            (t
1094             (mm-get-part handle))))))
1095
1096 (defun mm-file-name-delete-whitespace (file-name)
1097   "Remove all whitespace characters from FILE-NAME."
1098   (while (string-match "\\s-+" file-name)
1099     (setq file-name (replace-match "" t t file-name)))
1100   file-name)
1101
1102 (defun mm-file-name-trim-whitespace (file-name)
1103   "Remove leading and trailing whitespace characters from FILE-NAME."
1104   (when (string-match "\\`\\s-+" file-name)
1105     (setq file-name (substring file-name (match-end 0))))
1106   (when (string-match "\\s-+\\'" file-name)
1107     (setq file-name (substring file-name 0 (match-beginning 0))))
1108   file-name)
1109
1110 (defun mm-file-name-collapse-whitespace (file-name)
1111   "Collapse multiple whitespace characters in FILE-NAME."
1112   (while (string-match "\\s-\\s-+" file-name)
1113     (setq file-name (replace-match " " t t file-name)))
1114   file-name)
1115
1116 (defun mm-file-name-replace-whitespace (file-name)
1117   "Replace whitespace characters in FILE-NAME with underscores.
1118 Set the option `mm-file-name-replace-whitespace' to any other
1119 string if you do not like underscores."
1120   (let ((s (or mm-file-name-replace-whitespace "_")))
1121     (while (string-match "\\s-" file-name)
1122       (setq file-name (replace-match s t t file-name))))
1123   file-name)
1124
1125 (defun mm-file-name-delete-control (filename)
1126   "Delete control characters from FILENAME."
1127   (gnus-replace-in-string filename "[\x00-\x1f\x7f]" ""))
1128
1129 (defun mm-file-name-delete-gotchas (filename)
1130   "Delete shell gotchas from FILENAME."
1131   (setq filename (gnus-replace-in-string filename "[<>|]" ""))
1132   (gnus-replace-in-string filename "^[.-]+" ""))
1133
1134 (defun mm-save-part (handle &optional prompt)
1135   "Write HANDLE to a file.
1136 PROMPT overrides the default one used to ask user for a file name."
1137   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
1138          (filename (mail-content-type-get
1139                     (mm-handle-disposition handle) 'filename))
1140          file)
1141     (when filename
1142       (setq filename (gnus-map-function mm-file-name-rewrite-functions
1143                                         (file-name-nondirectory filename))))
1144     (setq file
1145           (mm-with-multibyte
1146             (read-file-name (or prompt "Save MIME part to: ")
1147                             (or mm-default-directory default-directory)
1148                             nil nil (or filename name ""))))
1149     (setq mm-default-directory (file-name-directory file))
1150     (and (or (not (file-exists-p file))
1151              (yes-or-no-p (format "File %s already exists; overwrite? "
1152                                   file)))
1153          (progn
1154            (mm-save-part-to-file handle file)
1155            file))))
1156
1157 (defun mm-save-part-to-file (handle file)
1158   (mm-with-unibyte-buffer
1159     (mm-insert-part handle)
1160     (let ((coding-system-for-write 'binary)
1161           (current-file-modes (default-file-modes))
1162           ;; Don't re-compress .gz & al.  Arguably we should make
1163           ;; `file-name-handler-alist' nil, but that would chop
1164           ;; ange-ftp, which is reasonable to use here.
1165           (inhibit-file-name-operation 'write-region)
1166           (inhibit-file-name-handlers
1167            (cons 'jka-compr-handler inhibit-file-name-handlers)))
1168       (set-default-file-modes mm-attachment-file-modes)
1169       (unwind-protect
1170           (write-region (point-min) (point-max) file)
1171         (set-default-file-modes current-file-modes)))))
1172
1173 (defun mm-pipe-part (handle)
1174   "Pipe HANDLE to a process."
1175   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
1176          (command
1177           (read-string "Shell command on MIME part: " mm-last-shell-command)))
1178     (mm-with-unibyte-buffer
1179       (mm-insert-part handle)
1180       (let ((coding-system-for-write 'binary))
1181         (shell-command-on-region (point-min) (point-max) command nil)))))
1182
1183 (defun mm-interactively-view-part (handle)
1184   "Display HANDLE using METHOD."
1185   (let* ((type (mm-handle-media-type handle))
1186          (methods
1187           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
1188                   (mailcap-mime-info type 'all)))
1189          (method (let ((minibuffer-local-completion-map
1190                         mm-viewer-completion-map))
1191                    (completing-read "Viewer: " methods))))
1192     (when (string= method "")
1193       (error "No method given"))
1194     (if (string-match "^[^% \t]+$" method)
1195         (setq method (concat method " %s")))
1196     (mm-display-external handle method)))
1197
1198 (defun mm-preferred-alternative (handles &optional preferred)
1199   "Say which of HANDLES are preferred."
1200   (let ((prec (if preferred (list preferred)
1201                 (mm-preferred-alternative-precedence handles)))
1202         p h result type handle)
1203     (while (setq p (pop prec))
1204       (setq h handles)
1205       (while h
1206         (setq handle (car h))
1207         (setq type (mm-handle-media-type handle))
1208         (when (and (equal p type)
1209                    (mm-automatic-display-p handle)
1210                    (or (stringp (car handle))
1211                        (not (mm-handle-disposition handle))
1212                        (equal (car (mm-handle-disposition handle))
1213                               "inline")))
1214           (setq result handle
1215                 h nil
1216                 prec nil))
1217         (pop h)))
1218     result))
1219
1220 (defun mm-preferred-alternative-precedence (handles)
1221   "Return the precedence based on HANDLES and `mm-discouraged-alternatives'."
1222   (let ((seq (nreverse (mapcar #'mm-handle-media-type
1223                                handles))))
1224     (dolist (disc (reverse mm-discouraged-alternatives))
1225       (dolist (elem (copy-sequence seq))
1226         (when (string-match disc elem)
1227           (setq seq (nconc (delete elem seq) (list elem))))))
1228     seq))
1229
1230 (defun mm-get-content-id (id)
1231   "Return the handle(s) referred to by ID."
1232   (cdr (assoc id mm-content-id-alist)))
1233
1234 (defconst mm-image-type-regexps
1235   '(("/\\*.*XPM.\\*/" . xpm)
1236     ("P[1-6]" . pbm)
1237     ("GIF8" . gif)
1238     ("\377\330" . jpeg)
1239     ("\211PNG\r\n" . png)
1240     ("#define" . xbm)
1241     ("\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff)
1242     ("%!PS" . postscript))
1243   "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types.
1244 When the first bytes of an image file match REGEXP, it is assumed to
1245 be of image type IMAGE-TYPE.")
1246
1247 ;; Steal from image.el. image-type-from-data suffers multi-line matching bug.
1248 (defun mm-image-type-from-buffer ()
1249   "Determine the image type from data in the current buffer.
1250 Value is a symbol specifying the image type or nil if type cannot
1251 be determined."
1252   (let ((types mm-image-type-regexps)
1253         type)
1254     (goto-char (point-min))
1255     (while (and types (null type))
1256       (let ((regexp (car (car types)))
1257             (image-type (cdr (car types))))
1258         (when (looking-at regexp)
1259           (setq type image-type))
1260         (setq types (cdr types))))
1261     type))
1262
1263 (defun mm-get-image (handle)
1264   "Return an image instance based on HANDLE."
1265   (let ((type (mm-handle-media-subtype handle))
1266         spec)
1267     ;; Allow some common translations.
1268     (setq type
1269           (cond
1270            ((equal type "x-pixmap")
1271             "xpm")
1272            ((equal type "x-xbitmap")
1273             "xbm")
1274            ((equal type "x-portable-bitmap")
1275             "pbm")
1276            (t type)))
1277     (or (mm-handle-cache handle)
1278         (mm-with-unibyte-buffer
1279           (mm-insert-part handle)
1280           (prog1
1281               (setq spec
1282                     (ignore-errors
1283                       ;; Avoid testing `make-glyph' since W3 may define
1284                       ;; a bogus version of it.
1285                       (if (fboundp 'create-image)
1286                           (create-image (buffer-string)
1287                                         (or (mm-image-type-from-buffer)
1288                                             (intern type))
1289                                         'data-p)
1290                         (mm-create-image-xemacs type))))
1291             (mm-handle-set-cache handle spec))))))
1292
1293 (defun mm-create-image-xemacs (type)
1294   (cond
1295    ((equal type "xbm")
1296     ;; xbm images require special handling, since
1297     ;; the only way to create glyphs from these
1298     ;; (without a ton of work) is to write them
1299     ;; out to a file, and then create a file
1300     ;; specifier.
1301     (let ((file (mm-make-temp-file
1302                  (expand-file-name "emm.xbm"
1303                                    mm-tmp-directory))))
1304       (unwind-protect
1305           (progn
1306             (write-region (point-min) (point-max) file)
1307             (make-glyph (list (cons 'x file))))
1308         (ignore-errors
1309           (delete-file file)))))
1310    (t
1311     (make-glyph
1312      (vector
1313       (or (mm-image-type-from-buffer)
1314           (intern type))
1315       :data (buffer-string))))))
1316
1317 (defun mm-image-fit-p (handle)
1318   "Say whether the image in HANDLE will fit the current window."
1319   (let ((image (mm-get-image handle)))
1320     (if (fboundp 'glyph-width)
1321         ;; XEmacs' glyphs can actually tell us about their width, so
1322         ;; lets be nice and smart about them.
1323         (or mm-inline-large-images
1324             (and (< (glyph-width image) (window-pixel-width))
1325                  (< (glyph-height image) (window-pixel-height))))
1326       (let* ((size (image-size image))
1327              (w (car size))
1328              (h (cdr size)))
1329         (or mm-inline-large-images
1330             (and (< h (1- (window-height))) ; Don't include mode line.
1331                  (< w (window-width))))))))
1332
1333 (defun mm-valid-image-format-p (format)
1334   "Say whether FORMAT can be displayed natively by Emacs."
1335   (cond
1336    ;; Handle XEmacs
1337    ((fboundp 'valid-image-instantiator-format-p)
1338     (valid-image-instantiator-format-p format))
1339    ;; Handle Emacs 21
1340    ((fboundp 'image-type-available-p)
1341     (and (display-graphic-p)
1342          (image-type-available-p format)))
1343    ;; Nobody else can do images yet.
1344    (t
1345     nil)))
1346
1347 (defun mm-valid-and-fit-image-p (format handle)
1348   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
1349   (and (mm-valid-image-format-p format)
1350        (mm-image-fit-p handle)))
1351
1352 (defun mm-find-part-by-type (handles type &optional notp recursive)
1353   "Search in HANDLES for part with TYPE.
1354 If NOTP, returns first non-matching part.
1355 If RECURSIVE, search recursively."
1356   (let (handle)
1357     (while handles
1358       (if (and recursive (stringp (caar handles)))
1359           (if (setq handle (mm-find-part-by-type (cdar handles) type
1360                                                  notp recursive))
1361               (setq handles nil))
1362         (if (if notp
1363                 (not (equal (mm-handle-media-type (car handles)) type))
1364               (equal (mm-handle-media-type (car handles)) type))
1365             (setq handle (car handles)
1366                   handles nil)))
1367       (setq handles (cdr handles)))
1368     handle))
1369
1370 (defun mm-find-raw-part-by-type (ctl type &optional notp)
1371   (goto-char (point-min))
1372   (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl
1373                                                                    'boundary)))
1374          (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$"))
1375          start
1376          (end (save-excursion
1377                 (goto-char (point-max))
1378                 (if (re-search-backward close-delimiter nil t)
1379                     (match-beginning 0)
1380                   (point-max))))
1381          result)
1382     (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$"))
1383     (while (and (not result)
1384                 (re-search-forward boundary end t))
1385       (goto-char (match-beginning 0))
1386       (when start
1387         (save-excursion
1388           (save-restriction
1389             (narrow-to-region start (1- (point)))
1390             (when (let ((ctl (ignore-errors
1391                                (mail-header-parse-content-type
1392                                 (mail-fetch-field "content-type")))))
1393                     (if notp
1394                         (not (equal (car ctl) type))
1395                       (equal (car ctl) type)))
1396               (setq result (buffer-string))))))
1397       (forward-line 1)
1398       (setq start (point)))
1399     (when (and (not result) start)
1400       (save-excursion
1401         (save-restriction
1402           (narrow-to-region start end)
1403           (when (let ((ctl (ignore-errors
1404                              (mail-header-parse-content-type
1405                               (mail-fetch-field "content-type")))))
1406                   (if notp
1407                       (not (equal (car ctl) type))
1408                     (equal (car ctl) type)))
1409             (setq result (buffer-string))))))
1410     result))
1411
1412 (defvar mm-security-handle nil)
1413
1414 (defsubst mm-set-handle-multipart-parameter (handle parameter value)
1415   ;; HANDLE could be a CTL.
1416   (when handle
1417     (put-text-property 0 (length (car handle)) parameter value
1418                        (car handle))))
1419
1420 (defun mm-possibly-verify-or-decrypt (parts ctl)
1421   (let ((type (car ctl))
1422         (subtype (cadr (split-string (car ctl) "/")))
1423         (mm-security-handle ctl) ;; (car CTL) is the type.
1424         protocol func functest)
1425     (cond
1426      ((or (equal type "application/x-pkcs7-mime")
1427           (equal type "application/pkcs7-mime"))
1428       (with-temp-buffer
1429         (when (and (cond
1430                     ((eq mm-decrypt-option 'never) nil)
1431                     ((eq mm-decrypt-option 'always) t)
1432                     ((eq mm-decrypt-option 'known) t)
1433                     (t (y-or-n-p
1434                         (format "Decrypt (S/MIME) part? "))))
1435                    (mm-view-pkcs7 parts))
1436           (setq parts (mm-dissect-buffer t)))))
1437      ((equal subtype "signed")
1438       (unless (and (setq protocol
1439                          (mm-handle-multipart-ctl-parameter ctl 'protocol))
1440                    (not (equal protocol "multipart/mixed")))
1441         ;; The message is broken or draft-ietf-openpgp-multsig-01.
1442         (let ((protocols mm-verify-function-alist))
1443           (while protocols
1444             (if (and (or (not (setq functest (nth 3 (car protocols))))
1445                          (funcall functest parts ctl))
1446                      (mm-find-part-by-type parts (caar protocols) nil t))
1447                 (setq protocol (caar protocols)
1448                       protocols nil)
1449               (setq protocols (cdr protocols))))))
1450       (setq func (nth 1 (assoc protocol mm-verify-function-alist)))
1451       (when (cond
1452              ((eq mm-verify-option 'never) nil)
1453              ((eq mm-verify-option 'always) t)
1454              ((eq mm-verify-option 'known)
1455               (and func
1456                    (or (not (setq functest
1457                                   (nth 3 (assoc protocol
1458                                                 mm-verify-function-alist))))
1459                        (funcall functest parts ctl))))
1460              (t
1461               (y-or-n-p
1462                (format "Verify signed (%s) part? "
1463                        (or (nth 2 (assoc protocol mm-verify-function-alist))
1464                            (format "protocol=%s" protocol))))))
1465         (save-excursion
1466           (if func
1467               (funcall func parts ctl)
1468             (mm-set-handle-multipart-parameter
1469              mm-security-handle 'gnus-details
1470              (format "Unknown sign protocol (%s)" protocol))))))
1471      ((equal subtype "encrypted")
1472       (unless (setq protocol
1473                     (mm-handle-multipart-ctl-parameter ctl 'protocol))
1474         ;; The message is broken.
1475         (let ((parts parts))
1476           (while parts
1477             (if (assoc (mm-handle-media-type (car parts))
1478                        mm-decrypt-function-alist)
1479                 (setq protocol (mm-handle-media-type (car parts))
1480                       parts nil)
1481               (setq parts (cdr parts))))))
1482       (setq func (nth 1 (assoc protocol mm-decrypt-function-alist)))
1483       (when (cond
1484              ((eq mm-decrypt-option 'never) nil)
1485              ((eq mm-decrypt-option 'always) t)
1486              ((eq mm-decrypt-option 'known)
1487               (and func
1488                    (or (not (setq functest
1489                                   (nth 3 (assoc protocol
1490                                                 mm-decrypt-function-alist))))
1491                        (funcall functest parts ctl))))
1492              (t
1493               (y-or-n-p
1494                (format "Decrypt (%s) part? "
1495                        (or (nth 2 (assoc protocol mm-decrypt-function-alist))
1496                            (format "protocol=%s" protocol))))))
1497         (save-excursion
1498           (if func
1499               (setq parts (funcall func parts ctl))
1500             (mm-set-handle-multipart-parameter
1501              mm-security-handle 'gnus-details
1502              (format "Unknown encrypt protocol (%s)" protocol))))))
1503      (t nil))
1504     parts))
1505
1506 (defun mm-multiple-handles (handles)
1507   (and (listp handles)
1508        (> (length handles) 1)
1509        (or (listp (car handles))
1510            (stringp (car handles)))))
1511
1512 (defun mm-complicated-handles (handles)
1513   (and (listp (car handles))
1514        (> (length handles) 1)))
1515
1516 (defun mm-merge-handles (handles1 handles2)
1517   (append
1518    (if (listp (car handles1))
1519        handles1
1520      (list handles1))
1521    (if (listp (car handles2))
1522        handles2
1523      (list handles2))))
1524
1525 (defun mm-readable-p (handle)
1526   "Say whether the content of HANDLE is readable."
1527   (and (< (with-current-buffer (mm-handle-buffer handle)
1528             (buffer-size)) 10000)
1529        (mm-with-unibyte-buffer
1530          (mm-insert-part handle)
1531          (and (eq (mm-body-7-or-8) '7bit)
1532               (not (mm-long-lines-p 76))))))
1533
1534 (provide 'mm-decode)
1535
1536 ;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b
1537 ;;; mm-decode.el ends here