code.delx.au - gnu-emacs/blob - lisp/gnus/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 'executable-find "executable")
  37   (autoload 'mm-inline-partial "mm-partial")
  38   (autoload 'mm-inline-external-body "mm-extern")
  39   (autoload 'mm-insert-inline "mm-view"))
  40
  41 (defvar gnus-current-window-configuration)
  42
  43 (add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list)
  44
  45 (defgroup mime-display ()
  46   "Display of MIME in mail and news articles."
  47   :link '(custom-manual "(emacs-mime)Display Customization")
  48   :version "21.1"
  49   :group 'mail
  50   :group 'news
  51   :group 'multimedia)
  52
  53 (defgroup mime-security ()
  54   "MIME security in mail and news articles."
  55   :link '(custom-manual "(emacs-mime)Display Customization")
  56   :group 'mail
  57   :group 'news
  58   :group 'multimedia)
  59
  60 ;;; Convenience macros.
  61
  62 (defmacro mm-handle-buffer (handle)
  63   `(nth 0 ,handle))
  64 (defmacro mm-handle-type (handle)
  65   `(nth 1 ,handle))
  66 (defsubst mm-handle-media-type (handle)
  67   (if (stringp (car handle))
  68       (car handle)
  69     (car (mm-handle-type handle))))
  70 (defsubst mm-handle-media-supertype (handle)
  71   (car (split-string (mm-handle-media-type handle) "/")))
  72 (defsubst mm-handle-media-subtype (handle)
  73   (cadr (split-string (mm-handle-media-type handle) "/")))
  74 (defmacro mm-handle-encoding (handle)
  75   `(nth 2 ,handle))
  76 (defmacro mm-handle-undisplayer (handle)
  77   `(nth 3 ,handle))
  78 (defmacro mm-handle-set-undisplayer (handle function)
  79   `(setcar (nthcdr 3 ,handle) ,function))
  80 (defmacro mm-handle-disposition (handle)
  81   `(nth 4 ,handle))
  82 (defmacro mm-handle-description (handle)
  83   `(nth 5 ,handle))
  84 (defmacro mm-handle-cache (handle)
  85   `(nth 6 ,handle))
  86 (defmacro mm-handle-set-cache (handle contents)
  87   `(setcar (nthcdr 6 ,handle) ,contents))
  88 (defmacro mm-handle-id (handle)
  89   `(nth 7 ,handle))
  90 (defmacro mm-handle-multipart-original-buffer (handle)
  91   `(get-text-property 0 'buffer (car ,handle)))
  92 (defmacro mm-handle-multipart-from (handle)
  93   `(get-text-property 0 'from (car ,handle)))
  94 (defmacro mm-handle-multipart-ctl-parameter (handle parameter)
  95   `(get-text-property 0 ,parameter (car ,handle)))
  96
  97 (defmacro mm-make-handle (&optional buffer type encoding undisplayer
  98                                     disposition description cache
  99                                     id)
 100   `(list ,buffer ,type ,encoding ,undisplayer
 101          ,disposition ,description ,cache ,id))
 102
 103 (defcustom mm-text-html-renderer
 104   (cond ((locate-library "w3") 'w3)
 105         ((executable-find "w3m") (if (locate-library "w3m")
 106                                      'w3m
 107                                    'w3m-standalone))
 108         ((executable-find "links") 'links)
 109         ((executable-find "lynx") 'lynx)
 110         (t 'html2text))
 111   "Render of HTML contents.
 112 It is one of defined renderer types, or a rendering function.
 113 The defined renderer types are:
 114 `w3'   : use Emacs/W3;
 115 `w3m'  : use emacs-w3m;
 116 `w3m-standalone': use w3m;
 117 `links': use links;
 118 `lynx' : use lynx;
 119 `html2text' : use html2text;
 120 nil    : use external viewer."
 121   :version "22.1"
 122   :type '(choice (const w3)
 123                  (const w3m)
 124                  (const w3m-standalone)
 125                  (const links)
 126                  (const lynx)
 127                  (const html2text)
 128                  (const nil)
 129                  (function))
 130   :group 'mime-display)
 131
 132 (defvar mm-inline-text-html-renderer nil
 133   "Function used for rendering inline HTML contents.
 134 It is suggested to customize `mm-text-html-renderer' instead.")
 135
 136 (defcustom mm-inline-text-html-with-images nil
 137   "If non-nil, Gnus will allow retrieving images in HTML contents with
 138 the <img> tags.  It has no effect on Emacs/w3.  See also the
 139 documentation for the `mm-w3m-safe-url-regexp' variable."
 140   :version "22.1"
 141   :type 'boolean
 142   :group 'mime-display)
 143
 144 (defcustom mm-w3m-safe-url-regexp "\\`cid:"
 145   "Regexp matching URLs which are considered to be safe.
 146 Some HTML mails might contain a nasty trick used by spammers, using
 147 the <img> tag which is far more evil than the [Click Here!] button.
 148 It is most likely intended to check whether the ominous spam mail has
 149 reached your eyes or not, in which case the spammer knows for sure
 150 that your email address is valid.  It is done by embedding an
 151 identifier string into a URL that you might automatically retrieve
 152 when displaying the image.  The default value is \"\\\\`cid:\" which only
 153 matches parts embedded to the Multipart/Related type MIME contents and
 154 Gnus will never connect to the spammer's site arbitrarily.  You may
 155 set this variable to nil if you consider all urls to be safe."
 156   :version "22.1"
 157   :type '(choice (regexp :tag "Regexp")
 158                  (const :tag "All URLs are safe" nil))
 159   :group 'mime-display)
 160
 161 (defcustom mm-inline-text-html-with-w3m-keymap t
 162   "If non-nil, use emacs-w3m command keys in the article buffer."
 163   :version "22.1"
 164   :type 'boolean
 165   :group 'mime-display)
 166
 167 (defcustom mm-enable-external t
 168   "Indicate whether external MIME handlers should be used.
 169
 170 If t, all defined external MIME handlers are used.  If nil, files are saved by
 171 `mailcap-save-binary-file'.  If it is the symbol `ask', you are prompted
 172 before the external MIME handler is invoked."
 173   :version "22.1"
 174   :type '(choice (const :tag "Always" t)
 175                  (const :tag "Never" nil)
 176                  (const :tag "Ask" ask))
 177   :group 'mime-display)
 178
 179 (defcustom mm-inline-media-tests
 180   '(("image/p?jpeg"
 181      mm-inline-image
 182      (lambda (handle)
 183        (mm-valid-and-fit-image-p 'jpeg handle)))
 184     ("image/png"
 185      mm-inline-image
 186      (lambda (handle)
 187        (mm-valid-and-fit-image-p 'png handle)))
 188     ("image/gif"
 189      mm-inline-image
 190      (lambda (handle)
 191        (mm-valid-and-fit-image-p 'gif handle)))
 192     ("image/tiff"
 193      mm-inline-image
 194      (lambda (handle)
 195        (mm-valid-and-fit-image-p 'tiff handle)) )
 196     ("image/xbm"
 197      mm-inline-image
 198      (lambda (handle)
 199        (mm-valid-and-fit-image-p 'xbm handle)))
 200     ("image/x-xbitmap"
 201      mm-inline-image
 202      (lambda (handle)
 203        (mm-valid-and-fit-image-p 'xbm handle)))
 204     ("image/xpm"
 205      mm-inline-image
 206      (lambda (handle)
 207        (mm-valid-and-fit-image-p 'xpm handle)))
 208     ("image/x-xpixmap"
 209      mm-inline-image
 210      (lambda (handle)
 211        (mm-valid-and-fit-image-p 'xpm handle)))
 212     ("image/bmp"
 213      mm-inline-image
 214      (lambda (handle)
 215        (mm-valid-and-fit-image-p 'bmp handle)))
 216     ("image/x-portable-bitmap"
 217      mm-inline-image
 218      (lambda (handle)
 219        (mm-valid-and-fit-image-p 'pbm handle)))
 220     ("text/plain" mm-inline-text identity)
 221     ("text/enriched" mm-inline-text identity)
 222     ("text/richtext" mm-inline-text identity)
 223     ("text/x-patch" mm-display-patch-inline
 224      (lambda (handle)
 225        ;; If the diff-mode.el package is installed, the function is
 226        ;; autoloaded.  Checking (locate-library "diff-mode") would be trying
 227        ;; to cater to broken installations.  OTOH checking the function
 228        ;; makes it possible to install another package which provides an
 229        ;; alternative implementation of diff-mode.  --Stef
 230        (fboundp 'diff-mode)))
 231     ("application/emacs-lisp" mm-display-elisp-inline identity)
 232     ("application/x-emacs-lisp" mm-display-elisp-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"
 300     "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
 301     "message/rfc822" "text/x-patch" "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       (when cte
 542         (setq cte (mail-header-strip cte)))
 543       (if (or (not ctl)
 544               (not (string-match "/" (car ctl))))
 545           (mm-dissect-singlepart
 546            (list mm-dissect-default-type)
 547            (and cte (intern (downcase (mail-header-remove-whitespace
 548                                        (mail-header-remove-comments
 549                                         cte)))))
 550            no-strict-mime
 551            (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
 552            description)
 553         (setq type (split-string (car ctl) "/"))
 554         (setq subtype (cadr type)
 555               type (pop type))
 556         (setq
 557          result
 558          (cond
 559           ((equal type "multipart")
 560            (let ((mm-dissect-default-type (if (equal subtype "digest")
 561                                               "message/rfc822"
 562                                             "text/plain"))
 563                  (start (cdr (assq 'start (cdr ctl)))))
 564              (add-text-properties 0 (length (car ctl))
 565                                   (mm-alist-to-plist (cdr ctl)) (car ctl))
 566
 567              ;; what really needs to be done here is a way to link a
 568              ;; MIME handle back to it's parent MIME handle (in a multilevel
 569              ;; MIME article).  That would probably require changing
 570              ;; the mm-handle API so we simply store the multipart buffer
 571              ;; name as a text property of the "multipart/whatever" string.
 572              (add-text-properties 0 (length (car ctl))
 573                                   (list 'buffer (mm-copy-to-buffer)
 574                                         'from from
 575                                         'start start)
 576                                   (car ctl))
 577              (cons (car ctl) (mm-dissect-multipart ctl from))))
 578           (t
 579            (mm-possibly-verify-or-decrypt
 580             (mm-dissect-singlepart
 581              ctl
 582              (and cte (intern (downcase (mail-header-remove-whitespace
 583                                          (mail-header-remove-comments
 584                                           cte)))))
 585              no-strict-mime
 586              (and cd (ignore-errors
 587                        (mail-header-parse-content-disposition cd)))
 588              description id)
 589             ctl))))
 590         (when id
 591           (when (string-match " *<\\(.*\\)> *" id)
 592             (setq id (match-string 1 id)))
 593           (push (cons id result) mm-content-id-alist))
 594         result))))
 595
 596 (defun mm-dissect-singlepart (ctl cte &optional force cdl description id)
 597   (when (or force
 598             (if (equal "text/plain" (car ctl))
 599                 (assoc 'format ctl)
 600               t))
 601     (mm-make-handle
 602      (mm-copy-to-buffer) ctl cte nil cdl description nil id)))
 603
 604 (defun mm-dissect-multipart (ctl from)
 605   (goto-char (point-min))
 606   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 607          (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
 608          start parts
 609          (end (save-excursion
 610                 (goto-char (point-max))
 611                 (if (re-search-backward close-delimiter nil t)
 612                     (match-beginning 0)
 613                   (point-max)))))
 614     (setq boundary (concat (regexp-quote boundary) "[ \t]*$"))
 615     (while (and (< (point) end) (re-search-forward boundary end t))
 616       (goto-char (match-beginning 0))
 617       (when start
 618         (save-excursion
 619           (save-restriction
 620             (narrow-to-region start (point))
 621             (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
 622       (end-of-line 2)
 623       (or (looking-at boundary)
 624           (forward-line 1))
 625       (setq start (point)))
 626     (when (and start (< start end))
 627       (save-excursion
 628         (save-restriction
 629           (narrow-to-region start end)
 630           (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
 631     (mm-possibly-verify-or-decrypt (nreverse parts) ctl)))
 632
 633 (defun mm-copy-to-buffer ()
 634   "Copy the contents of the current buffer to a fresh buffer."
 635   (save-excursion
 636     (let ((obuf (current-buffer))
 637           beg)
 638       (goto-char (point-min))
 639       (search-forward-regexp "^\n" nil t)
 640       (setq beg (point))
 641       (set-buffer
 642        ;; Preserve the data's unibyteness (for url-insert-file-contents).
 643        (let ((default-enable-multibyte-characters (mm-multibyte-p)))
 644          (generate-new-buffer " *mm*")))
 645       (insert-buffer-substring obuf beg)
 646       (current-buffer))))
 647
 648 (defun mm-display-parts (handle &optional no-default)
 649   (if (stringp (car handle))
 650       (mapcar 'mm-display-parts (cdr handle))
 651     (if (bufferp (car handle))
 652         (save-restriction
 653           (narrow-to-region (point) (point))
 654           (mm-display-part handle)
 655           (goto-char (point-max)))
 656       (mapcar 'mm-display-parts handle))))
 657
 658 (defun mm-display-part (handle &optional no-default)
 659   "Display the MIME part represented by HANDLE.
 660 Returns nil if the part is removed; inline if displayed inline;
 661 external if displayed external."
 662   (save-excursion
 663     (mailcap-parse-mailcaps)
 664     (if (mm-handle-displayed-p handle)
 665         (mm-remove-part handle)
 666       (let* ((type (mm-handle-media-type handle))
 667              (method (mailcap-mime-info type))
 668              (filename (or (mail-content-type-get
 669                             (mm-handle-disposition handle) 'filename)
 670                            (mail-content-type-get
 671                             (mm-handle-type handle) 'name)
 672                            "<file>"))
 673              (external mm-enable-external))
 674         (if (and (mm-inlinable-p handle)
 675                  (mm-inlined-p handle))
 676             (progn
 677               (forward-line 1)
 678               (mm-display-inline handle)
 679               'inline)
 680           (when (or method
 681                     (not no-default))
 682             (if (and (not method)
 683                      (equal "text" (car (split-string type))))
 684                 (progn
 685                   (forward-line 1)
 686                   (mm-insert-inline handle (mm-get-part handle))
 687                   'inline)
 688               (if (and method ;; If nil, we always use "save".
 689                        (stringp method) ;; 'mailcap-save-binary-file
 690                        (or (eq mm-enable-external t)
 691                            (and (eq mm-enable-external 'ask)
 692                                 (y-or-n-p
 693                                  (concat
 694                                   "Display part (" type
 695                                   ") using external program"
 696                                   ;; Can non-string method ever happen?
 697                                   (if (stringp method)
 698                                       (concat
 699                                        " \"" (format method filename) "\"")
 700                                     "")
 701                                   "? ")))))
 702                   (setq external t)
 703                 (setq external nil))
 704               (if external
 705                   (mm-display-external
 706                    handle (or method 'mailcap-save-binary-file))
 707                 (mm-display-external
 708                  handle 'mailcap-save-binary-file)))))))))
 709
 710 (defun mm-display-external (handle method)
 711   "Display HANDLE using METHOD."
 712   (let ((outbuf (current-buffer)))
 713     (mm-with-unibyte-buffer
 714       (if (functionp method)
 715           (let ((cur (current-buffer)))
 716             (if (eq method 'mailcap-save-binary-file)
 717                 (progn
 718                   (set-buffer (generate-new-buffer " *mm*"))
 719                   (setq method nil))
 720               (mm-insert-part handle)
 721               (let ((win (get-buffer-window cur t)))
 722                 (when win
 723                   (select-window win)))
 724               (switch-to-buffer (generate-new-buffer " *mm*")))
 725             (buffer-disable-undo)
 726             (mm-set-buffer-file-coding-system mm-binary-coding-system)
 727             (insert-buffer-substring cur)
 728             (goto-char (point-min))
 729             (when method
 730               (message "Viewing with %s" method))
 731             (let ((mm (current-buffer))
 732                   (non-viewer (assq 'non-viewer
 733                                     (mailcap-mime-info
 734                                      (mm-handle-media-type handle) t))))
 735               (unwind-protect
 736                   (if method
 737                       (funcall method)
 738                     (mm-save-part handle))
 739                 (when (and (not non-viewer)
 740                            method)
 741                   (mm-handle-set-undisplayer handle mm)))))
 742         ;; The function is a string to be executed.
 743         (mm-insert-part handle)
 744         (let* ((dir (mm-make-temp-file
 745                      (expand-file-name "emm." mm-tmp-directory) 'dir))
 746                (filename (or
 747                           (mail-content-type-get
 748                            (mm-handle-disposition handle) 'filename)
 749                           (mail-content-type-get
 750                            (mm-handle-type handle) 'name)))
 751                (mime-info (mailcap-mime-info
 752                            (mm-handle-media-type handle) t))
 753                (needsterm (or (assoc "needsterm" mime-info)
 754                               (assoc "needsterminal" mime-info)))
 755                (copiousoutput (assoc "copiousoutput" mime-info))
 756                file buffer)
 757           ;; We create a private sub-directory where we store our files.
 758           (set-file-modes dir 448)
 759           (if filename
 760               (setq file (expand-file-name
 761                           (gnus-map-function mm-file-name-rewrite-functions
 762                                              (file-name-nondirectory filename))
 763                           dir))
 764             (setq file (mm-make-temp-file (expand-file-name "mm." dir))))
 765           (let ((coding-system-for-write mm-binary-coding-system))
 766             (write-region (point-min) (point-max) file nil 'nomesg))
 767           (message "Viewing with %s" method)
 768           (cond
 769            (needsterm
 770             (let ((command (mm-mailcap-command
 771                             method file (mm-handle-type handle))))
 772               (unwind-protect
 773                   (if window-system
 774                       (start-process "*display*" nil
 775                                      mm-external-terminal-program
 776                                      "-e" shell-file-name
 777                                      shell-command-switch command)
 778                     (require 'term)
 779                     (require 'gnus-win)
 780                     (set-buffer
 781                      (setq buffer
 782                            (make-term "display"
 783                                       shell-file-name
 784                                       nil
 785                                       shell-command-switch command)))
 786                     (term-mode)
 787                     (term-char-mode)
 788                     (set-process-sentinel
 789                      (get-buffer-process buffer)
 790                      `(lambda (process state)
 791                         (if (eq 'exit (process-status process))
 792                             (gnus-configure-windows
 793                              ',gnus-current-window-configuration))))
 794                     (gnus-configure-windows 'display-term))
 795                 (mm-handle-set-external-undisplayer handle (cons file buffer)))
 796               (message "Displaying %s..." command))
 797             'external)
 798            (copiousoutput
 799             (with-current-buffer outbuf
 800               (forward-line 1)
 801               (mm-insert-inline
 802                handle
 803                (unwind-protect
 804                    (progn
 805                      (call-process shell-file-name nil
 806                                    (setq buffer
 807                                          (generate-new-buffer " *mm*"))
 808                                    nil
 809                                    shell-command-switch
 810                                    (mm-mailcap-command
 811                                     method file (mm-handle-type handle)))
 812                      (if (buffer-live-p buffer)
 813                          (with-current-buffer buffer
 814                            (buffer-string))))
 815                  (progn
 816                    (ignore-errors (delete-file file))
 817                    (ignore-errors (delete-directory
 818                                    (file-name-directory file)))
 819                    (ignore-errors (kill-buffer buffer))))))
 820             'inline)
 821            (t
 822             (let ((command (mm-mailcap-command
 823                             method file (mm-handle-type handle))))
 824               (unwind-protect
 825                   (progn
 826                     (start-process "*display*"
 827                                    (setq buffer
 828                                          (generate-new-buffer " *mm*"))
 829                                    shell-file-name
 830                                    shell-command-switch command)
 831                     (set-process-sentinel
 832                      (get-buffer-process buffer)
 833                      `(lambda (process state)
 834                         (when (eq 'exit (process-status process))
 835                           ;; Don't use `ignore-errors'.
 836                           (condition-case nil
 837                               (delete-file ,file)
 838                             (error))
 839                           (condition-case nil
 840                               (delete-directory ,(file-name-directory file))
 841                             (error))
 842                           (condition-case nil
 843                               (kill-buffer ,buffer)
 844                             (error))
 845                           (condition-case nil
 846                               ,(macroexpand (list 'mm-handle-set-undisplayer
 847                                                   (list 'quote handle)
 848                                                   nil))
 849                             (error))
 850                           (message "Displaying %s...done" ,command)))))
 851                 (mm-handle-set-external-undisplayer
 852                  handle (cons file buffer)))
 853               (message "Displaying %s..." command))
 854             'external)))))))
 855
 856 (defun mm-mailcap-command (method file type-list)
 857   (let ((ctl (cdr type-list))
 858         (beg 0)
 859         (uses-stdin t)
 860         out sub total)
 861     (while (string-match "%{\\([^}]+\\)}\\|'%s'\\|\"%s\"\\|%s\\|%t\\|%%"
 862                          method beg)
 863       (push (substring method beg (match-beginning 0)) out)
 864       (setq beg (match-end 0)
 865             total (match-string 0 method)
 866             sub (match-string 1 method))
 867       (cond
 868        ((string= total "%%")
 869         (push "%" out))
 870        ((or (string= total "%s")
 871             ;; We do our own quoting.
 872             (string= total "'%s'")
 873             (string= total "\"%s\""))
 874         (setq uses-stdin nil)
 875         (push (mm-quote-arg
 876                (gnus-map-function mm-path-name-rewrite-functions file)) out))
 877        ((string= total "%t")
 878         (push (mm-quote-arg (car type-list)) out))
 879        (t
 880         (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out))))
 881     (push (substring method beg (length method)) out)
 882     (when uses-stdin
 883       (push "<" out)
 884       (push (mm-quote-arg
 885              (gnus-map-function mm-path-name-rewrite-functions file))
 886             out))
 887     (mapconcat 'identity (nreverse out) "")))
 888
 889 (defun mm-remove-parts (handles)
 890   "Remove the displayed MIME parts represented by HANDLES."
 891   (if (and (listp handles)
 892            (bufferp (car handles)))
 893       (mm-remove-part handles)
 894     (let (handle)
 895       (while (setq handle (pop handles))
 896         (cond
 897          ((stringp handle)
 898           (when (buffer-live-p (get-text-property 0 'buffer handle))
 899             (kill-buffer (get-text-property 0 'buffer handle))))
 900          ((and (listp handle)
 901                (stringp (car handle)))
 902           (mm-remove-parts (cdr handle)))
 903          (t
 904           (mm-remove-part handle)))))))
 905
 906 (defun mm-destroy-parts (handles)
 907   "Remove the displayed MIME parts represented by HANDLES."
 908   (if (and (listp handles)
 909            (bufferp (car handles)))
 910       (mm-destroy-part handles)
 911     (let (handle)
 912       (while (setq handle (pop handles))
 913         (cond
 914          ((stringp handle)
 915           (when (buffer-live-p (get-text-property 0 'buffer handle))
 916             (kill-buffer (get-text-property 0 'buffer handle))))
 917          ((and (listp handle)
 918                (stringp (car handle)))
 919           (mm-destroy-parts handle))
 920          (t
 921           (mm-destroy-part handle)))))))
 922
 923 (defun mm-remove-part (handle)
 924   "Remove the displayed MIME part represented by HANDLE."
 925   (when (listp handle)
 926     (let ((object (mm-handle-undisplayer handle)))
 927       (ignore-errors
 928         (cond
 929          ;; Internally displayed part.
 930          ((mm-annotationp object)
 931           (delete-annotation object))
 932          ((or (functionp object)
 933               (and (listp object)
 934                    (eq (car object) 'lambda)))
 935           (funcall object))
 936          ;; Externally displayed part.
 937          ((consp object)
 938           (condition-case ()
 939               (while (get-buffer-process (cdr object))
 940                 (interrupt-process (get-buffer-process (cdr object)))
 941                 (message "Waiting for external displayer to die...")
 942                 (sit-for 1))
 943             (quit)
 944             (error))
 945           (ignore-errors (and (cdr object) (kill-buffer (cdr object))))
 946           (message "Waiting for external displayer to die...done")
 947           (ignore-errors (delete-file (car object)))
 948           (ignore-errors (delete-directory (file-name-directory
 949                                             (car object)))))
 950          ((bufferp object)
 951           (when (buffer-live-p object)
 952             (kill-buffer object)))))
 953       (mm-handle-set-undisplayer handle nil))))
 954
 955 (defun mm-display-inline (handle)
 956   (let* ((type (mm-handle-media-type handle))
 957          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
 958     (funcall function handle)
 959     (goto-char (point-min))))
 960
 961 (defun mm-assoc-string-match (alist type)
 962   (dolist (elem alist)
 963     (when (string-match (car elem) type)
 964       (return elem))))
 965
 966 (defun mm-automatic-display-p (handle)
 967   "Say whether the user wants HANDLE to be displayed automatically."
 968   (let ((methods mm-automatic-display)
 969         (type (mm-handle-media-type handle))
 970         method result)
 971     (while (setq method (pop methods))
 972       (when (and (not (mm-inline-override-p handle))
 973                  (string-match method type))
 974         (setq result t
 975               methods nil)))
 976     result))
 977
 978 (defun mm-inlinable-p (handle)
 979   "Say whether HANDLE can be displayed inline."
 980   (let ((alist mm-inline-media-tests)
 981         (type (mm-handle-media-type handle))
 982         test)
 983     (while alist
 984       (when (string-match (caar alist) type)
 985         (setq test (caddar alist)
 986               alist nil)
 987         (setq test (funcall test handle)))
 988       (pop alist))
 989     test))
 990
 991 (defun mm-inlined-p (handle)
 992   "Say whether the user wants HANDLE to be displayed inline."
 993   (let ((methods mm-inlined-types)
 994         (type (mm-handle-media-type handle))
 995         method result)
 996     (while (setq method (pop methods))
 997       (when (and (not (mm-inline-override-p handle))
 998                  (string-match method type))
 999         (setq result t
1000               methods nil)))
1001     result))
1002
1003 (defun mm-attachment-override-p (handle)
1004   "Say whether HANDLE should have attachment behavior overridden."
1005   (let ((types mm-attachment-override-types)
1006         (type (mm-handle-media-type handle))
1007         ty)
1008     (catch 'found
1009       (while (setq ty (pop types))
1010         (when (and (string-match ty type)
1011                    (mm-inlinable-p handle))
1012           (throw 'found t))))))
1013
1014 (defun mm-inline-override-p (handle)
1015   "Say whether HANDLE should have inline behavior overridden."
1016   (let ((types mm-inline-override-types)
1017         (type (mm-handle-media-type handle))
1018         ty)
1019     (catch 'found
1020       (while (setq ty (pop types))
1021         (when (string-match ty type)
1022           (throw 'found t))))))
1023
1024 (defun mm-automatic-external-display-p (type)
1025   "Return the user-defined method for TYPE."
1026   (let ((methods mm-automatic-external-display)
1027         method result)
1028     (while (setq method (pop methods))
1029       (when (string-match method type)
1030         (setq result t
1031               methods nil)))
1032     result))
1033
1034 (defun mm-destroy-part (handle)
1035   "Destroy the data structures connected to HANDLE."
1036   (when (listp handle)
1037     (mm-remove-part handle)
1038     (when (buffer-live-p (mm-handle-buffer handle))
1039       (kill-buffer (mm-handle-buffer handle)))))
1040
1041 (defun mm-handle-displayed-p (handle)
1042   "Say whether HANDLE is displayed or not."
1043   (mm-handle-undisplayer handle))
1044
1045 ;;;
1046 ;;; Functions for outputting parts
1047 ;;;
1048
1049 (defun mm-get-part (handle)
1050   "Return the contents of HANDLE as a string."
1051   (mm-with-unibyte-buffer
1052     (insert (with-current-buffer (mm-handle-buffer handle)
1053               (mm-with-unibyte-current-buffer
1054                 (buffer-string))))
1055     (mm-decode-content-transfer-encoding
1056      (mm-handle-encoding handle)
1057      (mm-handle-media-type handle))
1058     (buffer-string)))
1059
1060 (defun mm-insert-part (handle)
1061   "Insert the contents of HANDLE in the current buffer."
1062   (save-excursion
1063     (insert
1064      (cond ((eq (mail-content-type-get (mm-handle-type handle) 'charset)
1065                 'gnus-decoded)
1066             (with-current-buffer (mm-handle-buffer handle)
1067               (buffer-string)))
1068            ((mm-multibyte-p)
1069             (mm-string-as-multibyte (mm-get-part handle)))
1070            (t
1071             (mm-get-part handle))))))
1072
1073 (defun mm-file-name-delete-whitespace (file-name)
1074   "Remove all whitespace characters from FILE-NAME."
1075   (while (string-match "\\s-+" file-name)
1076     (setq file-name (replace-match "" t t file-name)))
1077   file-name)
1078
1079 (defun mm-file-name-trim-whitespace (file-name)
1080   "Remove leading and trailing whitespace characters from FILE-NAME."
1081   (when (string-match "\\`\\s-+" file-name)
1082     (setq file-name (substring file-name (match-end 0))))
1083   (when (string-match "\\s-+\\'" file-name)
1084     (setq file-name (substring file-name 0 (match-beginning 0))))
1085   file-name)
1086
1087 (defun mm-file-name-collapse-whitespace (file-name)
1088   "Collapse multiple whitespace characters in FILE-NAME."
1089   (while (string-match "\\s-\\s-+" file-name)
1090     (setq file-name (replace-match " " t t file-name)))
1091   file-name)
1092
1093 (defun mm-file-name-replace-whitespace (file-name)
1094   "Replace whitespace characters in FILE-NAME with underscores.
1095 Set the option `mm-file-name-replace-whitespace' to any other
1096 string if you do not like underscores."
1097   (let ((s (or mm-file-name-replace-whitespace "_")))
1098     (while (string-match "\\s-" file-name)
1099       (setq file-name (replace-match s t t file-name))))
1100   file-name)
1101
1102 (defun mm-file-name-delete-control (filename)
1103   "Delete control characters from FILENAME."
1104   (gnus-replace-in-string filename "[\x00-\x1f\x7f]" ""))
1105
1106 (defun mm-file-name-delete-gotchas (filename)
1107   "Delete shell gotchas from FILENAME."
1108   (setq filename (gnus-replace-in-string filename "[<>|]" ""))
1109   (gnus-replace-in-string filename "^[.-]+" ""))
1110
1111 (defun mm-save-part (handle)
1112   "Write HANDLE to a file."
1113   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
1114          (filename (mail-content-type-get
1115                     (mm-handle-disposition handle) 'filename))
1116          file)
1117     (when filename
1118       (setq filename (gnus-map-function mm-file-name-rewrite-functions
1119                                         (file-name-nondirectory filename))))
1120     (setq file
1121           (mm-with-multibyte
1122             (read-file-name "Save MIME part to: "
1123                             (or mm-default-directory default-directory)
1124                             nil nil (or filename name ""))))
1125     (setq mm-default-directory (file-name-directory file))
1126     (and (or (not (file-exists-p file))
1127              (yes-or-no-p (format "File %s already exists; overwrite? "
1128                                   file)))
1129          (progn
1130            (mm-save-part-to-file handle file)
1131            file))))
1132
1133 (defun mm-save-part-to-file (handle file)
1134   (mm-with-unibyte-buffer
1135     (mm-insert-part handle)
1136     (let ((coding-system-for-write 'binary)
1137           (current-file-modes (default-file-modes))
1138           ;; Don't re-compress .gz & al.  Arguably we should make
1139           ;; `file-name-handler-alist' nil, but that would chop
1140           ;; ange-ftp, which is reasonable to use here.
1141           (inhibit-file-name-operation 'write-region)
1142           (inhibit-file-name-handlers
1143            (cons 'jka-compr-handler inhibit-file-name-handlers)))
1144       (set-default-file-modes mm-attachment-file-modes)
1145       (unwind-protect
1146           (write-region (point-min) (point-max) file)
1147         (set-default-file-modes current-file-modes)))))
1148
1149 (defun mm-pipe-part (handle)
1150   "Pipe HANDLE to a process."
1151   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
1152          (command
1153           (read-string "Shell command on MIME part: " mm-last-shell-command)))
1154     (mm-with-unibyte-buffer
1155       (mm-insert-part handle)
1156       (let ((coding-system-for-write 'binary))
1157         (shell-command-on-region (point-min) (point-max) command nil)))))
1158
1159 (defun mm-interactively-view-part (handle)
1160   "Display HANDLE using METHOD."
1161   (let* ((type (mm-handle-media-type handle))
1162          (methods
1163           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
1164                   (mailcap-mime-info type 'all)))
1165          (method (let ((minibuffer-local-completion-map
1166                         mm-viewer-completion-map))
1167                    (completing-read "Viewer: " methods))))
1168     (when (string= method "")
1169       (error "No method given"))
1170     (if (string-match "^[^% \t]+$" method)
1171         (setq method (concat method " %s")))
1172     (mm-display-external handle method)))
1173
1174 (defun mm-preferred-alternative (handles &optional preferred)
1175   "Say which of HANDLES are preferred."
1176   (let ((prec (if preferred (list preferred)
1177                 (mm-preferred-alternative-precedence handles)))
1178         p h result type handle)
1179     (while (setq p (pop prec))
1180       (setq h handles)
1181       (while h
1182         (setq handle (car h))
1183         (setq type (mm-handle-media-type handle))
1184         (when (and (equal p type)
1185                    (mm-automatic-display-p handle)
1186                    (or (stringp (car handle))
1187                        (not (mm-handle-disposition handle))
1188                        (equal (car (mm-handle-disposition handle))
1189                               "inline")))
1190           (setq result handle
1191                 h nil
1192                 prec nil))
1193         (pop h)))
1194     result))
1195
1196 (defun mm-preferred-alternative-precedence (handles)
1197   "Return the precedence based on HANDLES and `mm-discouraged-alternatives'."
1198   (let ((seq (nreverse (mapcar #'mm-handle-media-type
1199                                handles))))
1200     (dolist (disc (reverse mm-discouraged-alternatives))
1201       (dolist (elem (copy-sequence seq))
1202         (when (string-match disc elem)
1203           (setq seq (nconc (delete elem seq) (list elem))))))
1204     seq))
1205
1206 (defun mm-get-content-id (id)
1207   "Return the handle(s) referred to by ID."
1208   (cdr (assoc id mm-content-id-alist)))
1209
1210 (defconst mm-image-type-regexps
1211   '(("/\\*.*XPM.\\*/" . xpm)
1212     ("P[1-6]" . pbm)
1213     ("GIF8" . gif)
1214     ("\377\330" . jpeg)
1215     ("\211PNG\r\n" . png)
1216     ("#define" . xbm)
1217     ("\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff)
1218     ("%!PS" . postscript))
1219   "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types.
1220 When the first bytes of an image file match REGEXP, it is assumed to
1221 be of image type IMAGE-TYPE.")
1222
1223 ;; Steal from image.el. image-type-from-data suffers multi-line matching bug.
1224 (defun mm-image-type-from-buffer ()
1225   "Determine the image type from data in the current buffer.
1226 Value is a symbol specifying the image type or nil if type cannot
1227 be determined."
1228   (let ((types mm-image-type-regexps)
1229         type)
1230     (goto-char (point-min))
1231     (while (and types (null type))
1232       (let ((regexp (car (car types)))
1233             (image-type (cdr (car types))))
1234         (when (looking-at regexp)
1235           (setq type image-type))
1236         (setq types (cdr types))))
1237     type))
1238
1239 (defun mm-get-image (handle)
1240   "Return an image instance based on HANDLE."
1241   (let ((type (mm-handle-media-subtype handle))
1242         spec)
1243     ;; Allow some common translations.
1244     (setq type
1245           (cond
1246            ((equal type "x-pixmap")
1247             "xpm")
1248            ((equal type "x-xbitmap")
1249             "xbm")
1250            ((equal type "x-portable-bitmap")
1251             "pbm")
1252            (t type)))
1253     (or (mm-handle-cache handle)
1254         (mm-with-unibyte-buffer
1255           (mm-insert-part handle)
1256           (prog1
1257               (setq spec
1258                     (ignore-errors
1259                       ;; Avoid testing `make-glyph' since W3 may define
1260                       ;; a bogus version of it.
1261                       (if (fboundp 'create-image)
1262                           (create-image (buffer-string)
1263                                         (or (mm-image-type-from-buffer)
1264                                             (intern type))
1265                                         'data-p)
1266                         (mm-create-image-xemacs type))))
1267             (mm-handle-set-cache handle spec))))))
1268
1269 (defun mm-create-image-xemacs (type)
1270   (cond
1271    ((equal type "xbm")
1272     ;; xbm images require special handling, since
1273     ;; the only way to create glyphs from these
1274     ;; (without a ton of work) is to write them
1275     ;; out to a file, and then create a file
1276     ;; specifier.
1277     (let ((file (mm-make-temp-file
1278                  (expand-file-name "emm.xbm"
1279                                    mm-tmp-directory))))
1280       (unwind-protect
1281           (progn
1282             (write-region (point-min) (point-max) file)
1283             (make-glyph (list (cons 'x file))))
1284         (ignore-errors
1285           (delete-file file)))))
1286    (t
1287     (make-glyph
1288      (vector
1289       (or (mm-image-type-from-buffer)
1290           (intern type))
1291       :data (buffer-string))))))
1292
1293 (defun mm-image-fit-p (handle)
1294   "Say whether the image in HANDLE will fit the current window."
1295   (let ((image (mm-get-image handle)))
1296     (if (fboundp 'glyph-width)
1297         ;; XEmacs' glyphs can actually tell us about their width, so
1298         ;; lets be nice and smart about them.
1299         (or mm-inline-large-images
1300             (and (< (glyph-width image) (window-pixel-width))
1301                  (< (glyph-height image) (window-pixel-height))))
1302       (let* ((size (image-size image))
1303              (w (car size))
1304              (h (cdr size)))
1305         (or mm-inline-large-images
1306             (and (< h (1- (window-height))) ; Don't include mode line.
1307                  (< w (window-width))))))))
1308
1309 (defun mm-valid-image-format-p (format)
1310   "Say whether FORMAT can be displayed natively by Emacs."
1311   (cond
1312    ;; Handle XEmacs
1313    ((fboundp 'valid-image-instantiator-format-p)
1314     (valid-image-instantiator-format-p format))
1315    ;; Handle Emacs 21
1316    ((fboundp 'image-type-available-p)
1317     (and (display-graphic-p)
1318          (image-type-available-p format)))
1319    ;; Nobody else can do images yet.
1320    (t
1321     nil)))
1322
1323 (defun mm-valid-and-fit-image-p (format handle)
1324   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
1325   (and (mm-valid-image-format-p format)
1326        (mm-image-fit-p handle)))
1327
1328 (defun mm-find-part-by-type (handles type &optional notp recursive)
1329   "Search in HANDLES for part with TYPE.
1330 If NOTP, returns first non-matching part.
1331 If RECURSIVE, search recursively."
1332   (let (handle)
1333     (while handles
1334       (if (and recursive (stringp (caar handles)))
1335           (if (setq handle (mm-find-part-by-type (cdar handles) type
1336                                                  notp recursive))
1337               (setq handles nil))
1338         (if (if notp
1339                 (not (equal (mm-handle-media-type (car handles)) type))
1340               (equal (mm-handle-media-type (car handles)) type))
1341             (setq handle (car handles)
1342                   handles nil)))
1343       (setq handles (cdr handles)))
1344     handle))
1345
1346 (defun mm-find-raw-part-by-type (ctl type &optional notp)
1347   (goto-char (point-min))
1348   (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl
1349                                                                    'boundary)))
1350          (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$"))
1351          start
1352          (end (save-excursion
1353                 (goto-char (point-max))
1354                 (if (re-search-backward close-delimiter nil t)
1355                     (match-beginning 0)
1356                   (point-max))))
1357          result)
1358     (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$"))
1359     (while (and (not result)
1360                 (re-search-forward boundary end t))
1361       (goto-char (match-beginning 0))
1362       (when start
1363         (save-excursion
1364           (save-restriction
1365             (narrow-to-region start (1- (point)))
1366             (when (let ((ctl (ignore-errors
1367                                (mail-header-parse-content-type
1368                                 (mail-fetch-field "content-type")))))
1369                     (if notp
1370                         (not (equal (car ctl) type))
1371                       (equal (car ctl) type)))
1372               (setq result (buffer-string))))))
1373       (forward-line 1)
1374       (setq start (point)))
1375     (when (and (not result) start)
1376       (save-excursion
1377         (save-restriction
1378           (narrow-to-region start end)
1379           (when (let ((ctl (ignore-errors
1380                              (mail-header-parse-content-type
1381                               (mail-fetch-field "content-type")))))
1382                   (if notp
1383                       (not (equal (car ctl) type))
1384                     (equal (car ctl) type)))
1385             (setq result (buffer-string))))))
1386     result))
1387
1388 (defvar mm-security-handle nil)
1389
1390 (defsubst mm-set-handle-multipart-parameter (handle parameter value)
1391   ;; HANDLE could be a CTL.
1392   (when handle
1393     (put-text-property 0 (length (car handle)) parameter value
1394                        (car handle))))
1395
1396 (defun mm-possibly-verify-or-decrypt (parts ctl)
1397   (let ((type (car ctl))
1398         (subtype (cadr (split-string (car ctl) "/")))
1399         (mm-security-handle ctl) ;; (car CTL) is the type.
1400         protocol func functest)
1401     (cond
1402      ((or (equal type "application/x-pkcs7-mime")
1403           (equal type "application/pkcs7-mime"))
1404       (with-temp-buffer
1405         (when (and (cond
1406                     ((eq mm-decrypt-option 'never) nil)
1407                     ((eq mm-decrypt-option 'always) t)
1408                     ((eq mm-decrypt-option 'known) t)
1409                     (t (y-or-n-p
1410                         (format "Decrypt (S/MIME) part? "))))
1411                    (mm-view-pkcs7 parts))
1412           (setq parts (mm-dissect-buffer t)))))
1413      ((equal subtype "signed")
1414       (unless (and (setq protocol
1415                          (mm-handle-multipart-ctl-parameter ctl 'protocol))
1416                    (not (equal protocol "multipart/mixed")))
1417         ;; The message is broken or draft-ietf-openpgp-multsig-01.
1418         (let ((protocols mm-verify-function-alist))
1419           (while protocols
1420             (if (and (or (not (setq functest (nth 3 (car protocols))))
1421                          (funcall functest parts ctl))
1422                      (mm-find-part-by-type parts (caar protocols) nil t))
1423                 (setq protocol (caar protocols)
1424                       protocols nil)
1425               (setq protocols (cdr protocols))))))
1426       (setq func (nth 1 (assoc protocol mm-verify-function-alist)))
1427       (when (cond
1428              ((eq mm-verify-option 'never) nil)
1429              ((eq mm-verify-option 'always) t)
1430              ((eq mm-verify-option 'known)
1431               (and func
1432                    (or (not (setq functest
1433                                   (nth 3 (assoc protocol
1434                                                 mm-verify-function-alist))))
1435                        (funcall functest parts ctl))))
1436              (t
1437               (y-or-n-p
1438                (format "Verify signed (%s) part? "
1439                        (or (nth 2 (assoc protocol mm-verify-function-alist))
1440                            (format "protocol=%s" protocol))))))
1441         (save-excursion
1442           (if func
1443               (funcall func parts ctl)
1444             (mm-set-handle-multipart-parameter
1445              mm-security-handle 'gnus-details
1446              (format "Unknown sign protocol (%s)" protocol))))))
1447      ((equal subtype "encrypted")
1448       (unless (setq protocol
1449                     (mm-handle-multipart-ctl-parameter ctl 'protocol))
1450         ;; The message is broken.
1451         (let ((parts parts))
1452           (while parts
1453             (if (assoc (mm-handle-media-type (car parts))
1454                        mm-decrypt-function-alist)
1455                 (setq protocol (mm-handle-media-type (car parts))
1456                       parts nil)
1457               (setq parts (cdr parts))))))
1458       (setq func (nth 1 (assoc protocol mm-decrypt-function-alist)))
1459       (when (cond
1460              ((eq mm-decrypt-option 'never) nil)
1461              ((eq mm-decrypt-option 'always) t)
1462              ((eq mm-decrypt-option 'known)
1463               (and func
1464                    (or (not (setq functest
1465                                   (nth 3 (assoc protocol
1466                                                 mm-decrypt-function-alist))))
1467                        (funcall functest parts ctl))))
1468              (t
1469               (y-or-n-p
1470                (format "Decrypt (%s) part? "
1471                        (or (nth 2 (assoc protocol mm-decrypt-function-alist))
1472                            (format "protocol=%s" protocol))))))
1473         (save-excursion
1474           (if func
1475               (setq parts (funcall func parts ctl))
1476             (mm-set-handle-multipart-parameter
1477              mm-security-handle 'gnus-details
1478              (format "Unknown encrypt protocol (%s)" protocol))))))
1479      (t nil))
1480     parts))
1481
1482 (defun mm-multiple-handles (handles)
1483   (and (listp handles)
1484        (> (length handles) 1)
1485        (or (listp (car handles))
1486            (stringp (car handles)))))
1487
1488 (defun mm-complicated-handles (handles)
1489   (and (listp (car handles))
1490        (> (length handles) 1)))
1491
1492 (defun mm-merge-handles (handles1 handles2)
1493   (append
1494    (if (listp (car handles1))
1495        handles1
1496      (list handles1))
1497    (if (listp (car handles2))
1498        handles2
1499      (list handles2))))
1500
1501 (defun mm-readable-p (handle)
1502   "Say whether the content of HANDLE is readable."
1503   (and (< (with-current-buffer (mm-handle-buffer handle)
1504             (buffer-size)) 10000)
1505        (mm-with-unibyte-buffer
1506          (mm-insert-part handle)
1507          (and (eq (mm-body-7-or-8) '7bit)
1508               (not (mm-long-lines-p 76))))))
1509
1510 (provide 'mm-decode)
1511
1512 ;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b
1513 ;;; mm-decode.el ends here