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 ((coding-system-for-write mm-binary-coding-system))
 760             (write-region (point-min) (point-max) file nil 'nomesg))
 761           (message "Viewing with %s" method)
 762           (cond
 763            (needsterm
 764             (let ((command (mm-mailcap-command
 765                             method file (mm-handle-type handle))))
 766               (unwind-protect
 767                   (if window-system
 768                       (start-process "*display*" nil
 769                                      mm-external-terminal-program
 770                                      "-e" shell-file-name
 771                                      shell-command-switch command)
 772                     (require 'term)
 773                     (require 'gnus-win)
 774                     (set-buffer
 775                      (setq buffer
 776                            (make-term "display"
 777                                       shell-file-name
 778                                       nil
 779                                       shell-command-switch command)))
 780                     (term-mode)
 781                     (term-char-mode)
 782                     (set-process-sentinel
 783                      (get-buffer-process buffer)
 784                      `(lambda (process state)
 785                         (if (eq 'exit (process-status process))
 786                             (gnus-configure-windows
 787                              ',gnus-current-window-configuration))))
 788                     (gnus-configure-windows 'display-term))
 789                 (mm-handle-set-external-undisplayer handle (cons file buffer)))
 790               (message "Displaying %s..." command))
 791             'external)
 792            (copiousoutput
 793             (with-current-buffer outbuf
 794               (forward-line 1)
 795               (mm-insert-inline
 796                handle
 797                (unwind-protect
 798                    (progn
 799                      (call-process shell-file-name nil
 800                                    (setq buffer
 801                                          (generate-new-buffer " *mm*"))
 802                                    nil
 803                                    shell-command-switch
 804                                    (mm-mailcap-command
 805                                     method file (mm-handle-type handle)))
 806                      (if (buffer-live-p buffer)
 807                          (with-current-buffer buffer
 808                            (buffer-string))))
 809                  (progn
 810                    (ignore-errors (delete-file file))
 811                    (ignore-errors (delete-directory
 812                                    (file-name-directory file)))
 813                    (ignore-errors (kill-buffer buffer))))))
 814             'inline)
 815            (t
 816             (let ((command (mm-mailcap-command
 817                             method file (mm-handle-type handle))))
 818               (unwind-protect
 819                   (progn
 820                     (start-process "*display*"
 821                                    (setq buffer
 822                                          (generate-new-buffer " *mm*"))
 823                                    shell-file-name
 824                                    shell-command-switch command)
 825                     (set-process-sentinel
 826                      (get-buffer-process buffer)
 827                      `(lambda (process state)
 828                         (when (eq 'exit (process-status process))
 829                           ;; Don't use `ignore-errors'.
 830                           (condition-case nil
 831                               (delete-file ,file)
 832                             (error))
 833                           (condition-case nil
 834                               (delete-directory ,(file-name-directory file))
 835                             (error))
 836                           (condition-case nil
 837                               (kill-buffer ,buffer)
 838                             (error))
 839                           (condition-case nil
 840                               ,(macroexpand (list 'mm-handle-set-undisplayer
 841                                                   (list 'quote handle)
 842                                                   nil))
 843                             (error))
 844                           (message "Displaying %s...done" ,command)))))
 845                 (mm-handle-set-external-undisplayer
 846                  handle (cons file buffer)))
 847               (message "Displaying %s..." command))
 848             'external)))))))
 849
 850 (defun mm-mailcap-command (method file type-list)
 851   (let ((ctl (cdr type-list))
 852         (beg 0)
 853         (uses-stdin t)
 854         out sub total)
 855     (while (string-match "%{\\([^}]+\\)}\\|'%s'\\|\"%s\"\\|%s\\|%t\\|%%"
 856                          method beg)
 857       (push (substring method beg (match-beginning 0)) out)
 858       (setq beg (match-end 0)
 859             total (match-string 0 method)
 860             sub (match-string 1 method))
 861       (cond
 862        ((string= total "%%")
 863         (push "%" out))
 864        ((or (string= total "%s")
 865             ;; We do our own quoting.
 866             (string= total "'%s'")
 867             (string= total "\"%s\""))
 868         (setq uses-stdin nil)
 869         (push (shell-quote-argument
 870                (gnus-map-function mm-path-name-rewrite-functions file)) out))
 871        ((string= total "%t")
 872         (push (shell-quote-argument (car type-list)) out))
 873        (t
 874         (push (shell-quote-argument (or (cdr (assq (intern sub) ctl)) "")) out))))
 875     (push (substring method beg (length method)) out)
 876     (when uses-stdin
 877       (push "<" out)
 878       (push (shell-quote-argument
 879              (gnus-map-function mm-path-name-rewrite-functions file))
 880             out))
 881     (mapconcat 'identity (nreverse out) "")))
 882
 883 (defun mm-remove-parts (handles)
 884   "Remove the displayed MIME parts represented by HANDLES."
 885   (if (and (listp handles)
 886            (bufferp (car handles)))
 887       (mm-remove-part handles)
 888     (let (handle)
 889       (while (setq handle (pop handles))
 890         (cond
 891          ((stringp handle)
 892           (when (buffer-live-p (get-text-property 0 'buffer handle))
 893             (kill-buffer (get-text-property 0 'buffer handle))))
 894          ((and (listp handle)
 895                (stringp (car handle)))
 896           (mm-remove-parts (cdr handle)))
 897          (t
 898           (mm-remove-part handle)))))))
 899
 900 (defun mm-destroy-parts (handles)
 901   "Remove the displayed MIME parts represented by HANDLES."
 902   (if (and (listp handles)
 903            (bufferp (car handles)))
 904       (mm-destroy-part handles)
 905     (let (handle)
 906       (while (setq handle (pop handles))
 907         (cond
 908          ((stringp handle)
 909           (when (buffer-live-p (get-text-property 0 'buffer handle))
 910             (kill-buffer (get-text-property 0 'buffer handle))))
 911          ((and (listp handle)
 912                (stringp (car handle)))
 913           (mm-destroy-parts handle))
 914          (t
 915           (mm-destroy-part handle)))))))
 916
 917 (defun mm-remove-part (handle)
 918   "Remove the displayed MIME part represented by HANDLE."
 919   (when (listp handle)
 920     (let ((object (mm-handle-undisplayer handle)))
 921       (ignore-errors
 922         (cond
 923          ;; Internally displayed part.
 924          ((mm-annotationp object)
 925           (delete-annotation object))
 926          ((or (functionp object)
 927               (and (listp object)
 928                    (eq (car object) 'lambda)))
 929           (funcall object))
 930          ;; Externally displayed part.
 931          ((consp object)
 932           (condition-case ()
 933               (while (get-buffer-process (cdr object))
 934                 (interrupt-process (get-buffer-process (cdr object)))
 935                 (message "Waiting for external displayer to die...")
 936                 (sit-for 1))
 937             (quit)
 938             (error))
 939           (ignore-errors (and (cdr object) (kill-buffer (cdr object))))
 940           (message "Waiting for external displayer to die...done")
 941           (ignore-errors (delete-file (car object)))
 942           (ignore-errors (delete-directory (file-name-directory
 943                                             (car object)))))
 944          ((bufferp object)
 945           (when (buffer-live-p object)
 946             (kill-buffer object)))))
 947       (mm-handle-set-undisplayer handle nil))))
 948
 949 (defun mm-display-inline (handle)
 950   (let* ((type (mm-handle-media-type handle))
 951          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
 952     (funcall function handle)
 953     (goto-char (point-min))))
 954
 955 (defun mm-assoc-string-match (alist type)
 956   (dolist (elem alist)
 957     (when (string-match (car elem) type)
 958       (return elem))))
 959
 960 (defun mm-automatic-display-p (handle)
 961   "Say whether the user wants HANDLE to be displayed automatically."
 962   (let ((methods mm-automatic-display)
 963         (type (mm-handle-media-type handle))
 964         method result)
 965     (while (setq method (pop methods))
 966       (when (and (not (mm-inline-override-p handle))
 967                  (string-match method type))
 968         (setq result t
 969               methods nil)))
 970     result))
 971
 972 (defun mm-inlinable-p (handle)
 973   "Say whether HANDLE can be displayed inline."
 974   (let ((alist mm-inline-media-tests)
 975         (type (mm-handle-media-type handle))
 976         test)
 977     (while alist
 978       (when (string-match (caar alist) type)
 979         (setq test (caddar alist)
 980               alist nil)
 981         (setq test (funcall test handle)))
 982       (pop alist))
 983     test))
 984
 985 (defun mm-inlined-p (handle)
 986   "Say whether the user wants HANDLE to be displayed inline."
 987   (let ((methods mm-inlined-types)
 988         (type (mm-handle-media-type handle))
 989         method result)
 990     (while (setq method (pop methods))
 991       (when (and (not (mm-inline-override-p handle))
 992                  (string-match method type))
 993         (setq result t
 994               methods nil)))
 995     result))
 996
 997 (defun mm-attachment-override-p (handle)
 998   "Say whether HANDLE should have attachment behavior overridden."
 999   (let ((types mm-attachment-override-types)
1000         (type (mm-handle-media-type handle))
1001         ty)
1002     (catch 'found
1003       (while (setq ty (pop types))
1004         (when (and (string-match ty type)
1005                    (mm-inlinable-p handle))
1006           (throw 'found t))))))
1007
1008 (defun mm-inline-override-p (handle)
1009   "Say whether HANDLE should have inline behavior overridden."
1010   (let ((types mm-inline-override-types)
1011         (type (mm-handle-media-type handle))
1012         ty)
1013     (catch 'found
1014       (while (setq ty (pop types))
1015         (when (string-match ty type)
1016           (throw 'found t))))))
1017
1018 (defun mm-automatic-external-display-p (type)
1019   "Return the user-defined method for TYPE."
1020   (let ((methods mm-automatic-external-display)
1021         method result)
1022     (while (setq method (pop methods))
1023       (when (string-match method type)
1024         (setq result t
1025               methods nil)))
1026     result))
1027
1028 (defun mm-destroy-part (handle)
1029   "Destroy the data structures connected to HANDLE."
1030   (when (listp handle)
1031     (mm-remove-part handle)
1032     (when (buffer-live-p (mm-handle-buffer handle))
1033       (kill-buffer (mm-handle-buffer handle)))))
1034
1035 (defun mm-handle-displayed-p (handle)
1036   "Say whether HANDLE is displayed or not."
1037   (mm-handle-undisplayer handle))
1038
1039 ;;;
1040 ;;; Functions for outputting parts
1041 ;;;
1042
1043 (defun mm-get-part (handle)
1044   "Return the contents of HANDLE as a string."
1045   (mm-with-unibyte-buffer
1046     (insert (with-current-buffer (mm-handle-buffer handle)
1047               (mm-with-unibyte-current-buffer
1048                 (buffer-string))))
1049     (mm-decode-content-transfer-encoding
1050      (mm-handle-encoding handle)
1051      (mm-handle-media-type handle))
1052     (buffer-string)))
1053
1054 (defun mm-insert-part (handle)
1055   "Insert the contents of HANDLE in the current buffer."
1056   (save-excursion
1057     (insert
1058      (cond ((eq (mail-content-type-get (mm-handle-type handle) 'charset)
1059                 'gnus-decoded)
1060             (with-current-buffer (mm-handle-buffer handle)
1061               (buffer-string)))
1062            ((mm-multibyte-p)
1063             (mm-string-as-multibyte (mm-get-part handle)))
1064            (t
1065             (mm-get-part handle))))))
1066
1067 (defun mm-file-name-delete-whitespace (file-name)
1068   "Remove all whitespace characters from FILE-NAME."
1069   (while (string-match "\\s-+" file-name)
1070     (setq file-name (replace-match "" t t file-name)))
1071   file-name)
1072
1073 (defun mm-file-name-trim-whitespace (file-name)
1074   "Remove leading and trailing whitespace characters from FILE-NAME."
1075   (when (string-match "\\`\\s-+" file-name)
1076     (setq file-name (substring file-name (match-end 0))))
1077   (when (string-match "\\s-+\\'" file-name)
1078     (setq file-name (substring file-name 0 (match-beginning 0))))
1079   file-name)
1080
1081 (defun mm-file-name-collapse-whitespace (file-name)
1082   "Collapse multiple whitespace characters in FILE-NAME."
1083   (while (string-match "\\s-\\s-+" file-name)
1084     (setq file-name (replace-match " " t t file-name)))
1085   file-name)
1086
1087 (defun mm-file-name-replace-whitespace (file-name)
1088   "Replace whitespace characters in FILE-NAME with underscores.
1089 Set the option `mm-file-name-replace-whitespace' to any other
1090 string if you do not like underscores."
1091   (let ((s (or mm-file-name-replace-whitespace "_")))
1092     (while (string-match "\\s-" file-name)
1093       (setq file-name (replace-match s t t file-name))))
1094   file-name)
1095
1096 (defun mm-file-name-delete-control (filename)
1097   "Delete control characters from FILENAME."
1098   (gnus-replace-in-string filename "[\x00-\x1f\x7f]" ""))
1099
1100 (defun mm-file-name-delete-gotchas (filename)
1101   "Delete shell gotchas from FILENAME."
1102   (setq filename (gnus-replace-in-string filename "[<>|]" ""))
1103   (gnus-replace-in-string filename "^[.-]+" ""))
1104
1105 (defun mm-save-part (handle &optional prompt)
1106   "Write HANDLE to a file.
1107 PROMPT overrides the default one used to ask user for a file name."
1108   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
1109          (filename (mail-content-type-get
1110                     (mm-handle-disposition handle) 'filename))
1111          file)
1112     (when filename
1113       (setq filename (gnus-map-function mm-file-name-rewrite-functions
1114                                         (file-name-nondirectory filename))))
1115     (setq file
1116           (mm-with-multibyte
1117             (read-file-name (or prompt "Save MIME part to: ")
1118                             (or mm-default-directory default-directory)
1119                             nil nil (or filename name ""))))
1120     (setq mm-default-directory (file-name-directory file))
1121     (and (or (not (file-exists-p file))
1122              (yes-or-no-p (format "File %s already exists; overwrite? "
1123                                   file)))
1124          (progn
1125            (mm-save-part-to-file handle file)
1126            file))))
1127
1128 (defun mm-save-part-to-file (handle file)
1129   (mm-with-unibyte-buffer
1130     (mm-insert-part handle)
1131     (let ((coding-system-for-write 'binary)
1132           (current-file-modes (default-file-modes))
1133           ;; Don't re-compress .gz & al.  Arguably we should make
1134           ;; `file-name-handler-alist' nil, but that would chop
1135           ;; ange-ftp, which is reasonable to use here.
1136           (inhibit-file-name-operation 'write-region)
1137           (inhibit-file-name-handlers
1138            (cons 'jka-compr-handler inhibit-file-name-handlers)))
1139       (set-default-file-modes mm-attachment-file-modes)
1140       (unwind-protect
1141           (write-region (point-min) (point-max) file)
1142         (set-default-file-modes current-file-modes)))))
1143
1144 (defun mm-pipe-part (handle)
1145   "Pipe HANDLE to a process."
1146   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
1147          (command
1148           (read-string "Shell command on MIME part: " mm-last-shell-command)))
1149     (mm-with-unibyte-buffer
1150       (mm-insert-part handle)
1151       (let ((coding-system-for-write 'binary))
1152         (shell-command-on-region (point-min) (point-max) command nil)))))
1153
1154 (defun mm-interactively-view-part (handle)
1155   "Display HANDLE using METHOD."
1156   (let* ((type (mm-handle-media-type handle))
1157          (methods
1158           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
1159                   (mailcap-mime-info type 'all)))
1160          (method (let ((minibuffer-local-completion-map
1161                         mm-viewer-completion-map))
1162                    (completing-read "Viewer: " methods))))
1163     (when (string= method "")
1164       (error "No method given"))
1165     (if (string-match "^[^% \t]+$" method)
1166         (setq method (concat method " %s")))
1167     (mm-display-external handle method)))
1168
1169 (defun mm-preferred-alternative (handles &optional preferred)
1170   "Say which of HANDLES are preferred."
1171   (let ((prec (if preferred (list preferred)
1172                 (mm-preferred-alternative-precedence handles)))
1173         p h result type handle)
1174     (while (setq p (pop prec))
1175       (setq h handles)
1176       (while h
1177         (setq handle (car h))
1178         (setq type (mm-handle-media-type handle))
1179         (when (and (equal p type)
1180                    (mm-automatic-display-p handle)
1181                    (or (stringp (car handle))
1182                        (not (mm-handle-disposition handle))
1183                        (equal (car (mm-handle-disposition handle))
1184                               "inline")))
1185           (setq result handle
1186                 h nil
1187                 prec nil))
1188         (pop h)))
1189     result))
1190
1191 (defun mm-preferred-alternative-precedence (handles)
1192   "Return the precedence based on HANDLES and `mm-discouraged-alternatives'."
1193   (let ((seq (nreverse (mapcar #'mm-handle-media-type
1194                                handles))))
1195     (dolist (disc (reverse mm-discouraged-alternatives))
1196       (dolist (elem (copy-sequence seq))
1197         (when (string-match disc elem)
1198           (setq seq (nconc (delete elem seq) (list elem))))))
1199     seq))
1200
1201 (defun mm-get-content-id (id)
1202   "Return the handle(s) referred to by ID."
1203   (cdr (assoc id mm-content-id-alist)))
1204
1205 (defconst mm-image-type-regexps
1206   '(("/\\*.*XPM.\\*/" . xpm)
1207     ("P[1-6]" . pbm)
1208     ("GIF8" . gif)
1209     ("\377\330" . jpeg)
1210     ("\211PNG\r\n" . png)
1211     ("#define" . xbm)
1212     ("\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff)
1213     ("%!PS" . postscript))
1214   "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types.
1215 When the first bytes of an image file match REGEXP, it is assumed to
1216 be of image type IMAGE-TYPE.")
1217
1218 ;; Steal from image.el. image-type-from-data suffers multi-line matching bug.
1219 (defun mm-image-type-from-buffer ()
1220   "Determine the image type from data in the current buffer.
1221 Value is a symbol specifying the image type or nil if type cannot
1222 be determined."
1223   (let ((types mm-image-type-regexps)
1224         type)
1225     (goto-char (point-min))
1226     (while (and types (null type))
1227       (let ((regexp (car (car types)))
1228             (image-type (cdr (car types))))
1229         (when (looking-at regexp)
1230           (setq type image-type))
1231         (setq types (cdr types))))
1232     type))
1233
1234 (defun mm-get-image (handle)
1235   "Return an image instance based on HANDLE."
1236   (let ((type (mm-handle-media-subtype handle))
1237         spec)
1238     ;; Allow some common translations.
1239     (setq type
1240           (cond
1241            ((equal type "x-pixmap")
1242             "xpm")
1243            ((equal type "x-xbitmap")
1244             "xbm")
1245            ((equal type "x-portable-bitmap")
1246             "pbm")
1247            (t type)))
1248     (or (mm-handle-cache handle)
1249         (mm-with-unibyte-buffer
1250           (mm-insert-part handle)
1251           (prog1
1252               (setq spec
1253                     (ignore-errors
1254                       ;; Avoid testing `make-glyph' since W3 may define
1255                       ;; a bogus version of it.
1256                       (if (fboundp 'create-image)
1257                           (create-image (buffer-string)
1258                                         (or (mm-image-type-from-buffer)
1259                                             (intern type))
1260                                         'data-p)
1261                         (mm-create-image-xemacs type))))
1262             (mm-handle-set-cache handle spec))))))
1263
1264 (defun mm-create-image-xemacs (type)
1265   (cond
1266    ((equal type "xbm")
1267     ;; xbm images require special handling, since
1268     ;; the only way to create glyphs from these
1269     ;; (without a ton of work) is to write them
1270     ;; out to a file, and then create a file
1271     ;; specifier.
1272     (let ((file (mm-make-temp-file
1273                  (expand-file-name "emm.xbm"
1274                                    mm-tmp-directory))))
1275       (unwind-protect
1276           (progn
1277             (write-region (point-min) (point-max) file)
1278             (make-glyph (list (cons 'x file))))
1279         (ignore-errors
1280           (delete-file file)))))
1281    (t
1282     (make-glyph
1283      (vector
1284       (or (mm-image-type-from-buffer)
1285           (intern type))
1286       :data (buffer-string))))))
1287
1288 (defun mm-image-fit-p (handle)
1289   "Say whether the image in HANDLE will fit the current window."
1290   (let ((image (mm-get-image handle)))
1291     (if (fboundp 'glyph-width)
1292         ;; XEmacs' glyphs can actually tell us about their width, so
1293         ;; lets be nice and smart about them.
1294         (or mm-inline-large-images
1295             (and (< (glyph-width image) (window-pixel-width))
1296                  (< (glyph-height image) (window-pixel-height))))
1297       (let* ((size (image-size image))
1298              (w (car size))
1299              (h (cdr size)))
1300         (or mm-inline-large-images
1301             (and (< h (1- (window-height))) ; Don't include mode line.
1302                  (< w (window-width))))))))
1303
1304 (defun mm-valid-image-format-p (format)
1305   "Say whether FORMAT can be displayed natively by Emacs."
1306   (cond
1307    ;; Handle XEmacs
1308    ((fboundp 'valid-image-instantiator-format-p)
1309     (valid-image-instantiator-format-p format))
1310    ;; Handle Emacs 21
1311    ((fboundp 'image-type-available-p)
1312     (and (display-graphic-p)
1313          (image-type-available-p format)))
1314    ;; Nobody else can do images yet.
1315    (t
1316     nil)))
1317
1318 (defun mm-valid-and-fit-image-p (format handle)
1319   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
1320   (and (mm-valid-image-format-p format)
1321        (mm-image-fit-p handle)))
1322
1323 (defun mm-find-part-by-type (handles type &optional notp recursive)
1324   "Search in HANDLES for part with TYPE.
1325 If NOTP, returns first non-matching part.
1326 If RECURSIVE, search recursively."
1327   (let (handle)
1328     (while handles
1329       (if (and recursive (stringp (caar handles)))
1330           (if (setq handle (mm-find-part-by-type (cdar handles) type
1331                                                  notp recursive))
1332               (setq handles nil))
1333         (if (if notp
1334                 (not (equal (mm-handle-media-type (car handles)) type))
1335               (equal (mm-handle-media-type (car handles)) type))
1336             (setq handle (car handles)
1337                   handles nil)))
1338       (setq handles (cdr handles)))
1339     handle))
1340
1341 (defun mm-find-raw-part-by-type (ctl type &optional notp)
1342   (goto-char (point-min))
1343   (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl
1344                                                                    'boundary)))
1345          (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$"))
1346          start
1347          (end (save-excursion
1348                 (goto-char (point-max))
1349                 (if (re-search-backward close-delimiter nil t)
1350                     (match-beginning 0)
1351                   (point-max))))
1352          result)
1353     (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$"))
1354     (while (and (not result)
1355                 (re-search-forward boundary end t))
1356       (goto-char (match-beginning 0))
1357       (when start
1358         (save-excursion
1359           (save-restriction
1360             (narrow-to-region start (1- (point)))
1361             (when (let ((ctl (ignore-errors
1362                                (mail-header-parse-content-type
1363                                 (mail-fetch-field "content-type")))))
1364                     (if notp
1365                         (not (equal (car ctl) type))
1366                       (equal (car ctl) type)))
1367               (setq result (buffer-string))))))
1368       (forward-line 1)
1369       (setq start (point)))
1370     (when (and (not result) start)
1371       (save-excursion
1372         (save-restriction
1373           (narrow-to-region start end)
1374           (when (let ((ctl (ignore-errors
1375                              (mail-header-parse-content-type
1376                               (mail-fetch-field "content-type")))))
1377                   (if notp
1378                       (not (equal (car ctl) type))
1379                     (equal (car ctl) type)))
1380             (setq result (buffer-string))))))
1381     result))
1382
1383 (defvar mm-security-handle nil)
1384
1385 (defsubst mm-set-handle-multipart-parameter (handle parameter value)
1386   ;; HANDLE could be a CTL.
1387   (when handle
1388     (put-text-property 0 (length (car handle)) parameter value
1389                        (car handle))))
1390
1391 (defun mm-possibly-verify-or-decrypt (parts ctl)
1392   (let ((type (car ctl))
1393         (subtype (cadr (split-string (car ctl) "/")))
1394         (mm-security-handle ctl) ;; (car CTL) is the type.
1395         protocol func functest)
1396     (cond
1397      ((or (equal type "application/x-pkcs7-mime")
1398           (equal type "application/pkcs7-mime"))
1399       (with-temp-buffer
1400         (when (and (cond
1401                     ((eq mm-decrypt-option 'never) nil)
1402                     ((eq mm-decrypt-option 'always) t)
1403                     ((eq mm-decrypt-option 'known) t)
1404                     (t (y-or-n-p
1405                         (format "Decrypt (S/MIME) part? "))))
1406                    (mm-view-pkcs7 parts))
1407           (setq parts (mm-dissect-buffer t)))))
1408      ((equal subtype "signed")
1409       (unless (and (setq protocol
1410                          (mm-handle-multipart-ctl-parameter ctl 'protocol))
1411                    (not (equal protocol "multipart/mixed")))
1412         ;; The message is broken or draft-ietf-openpgp-multsig-01.
1413         (let ((protocols mm-verify-function-alist))
1414           (while protocols
1415             (if (and (or (not (setq functest (nth 3 (car protocols))))
1416                          (funcall functest parts ctl))
1417                      (mm-find-part-by-type parts (caar protocols) nil t))
1418                 (setq protocol (caar protocols)
1419                       protocols nil)
1420               (setq protocols (cdr protocols))))))
1421       (setq func (nth 1 (assoc protocol mm-verify-function-alist)))
1422       (when (cond
1423              ((eq mm-verify-option 'never) nil)
1424              ((eq mm-verify-option 'always) t)
1425              ((eq mm-verify-option 'known)
1426               (and func
1427                    (or (not (setq functest
1428                                   (nth 3 (assoc protocol
1429                                                 mm-verify-function-alist))))
1430                        (funcall functest parts ctl))))
1431              (t
1432               (y-or-n-p
1433                (format "Verify signed (%s) part? "
1434                        (or (nth 2 (assoc protocol mm-verify-function-alist))
1435                            (format "protocol=%s" protocol))))))
1436         (save-excursion
1437           (if func
1438               (funcall func parts ctl)
1439             (mm-set-handle-multipart-parameter
1440              mm-security-handle 'gnus-details
1441              (format "Unknown sign protocol (%s)" protocol))))))
1442      ((equal subtype "encrypted")
1443       (unless (setq protocol
1444                     (mm-handle-multipart-ctl-parameter ctl 'protocol))
1445         ;; The message is broken.
1446         (let ((parts parts))
1447           (while parts
1448             (if (assoc (mm-handle-media-type (car parts))
1449                        mm-decrypt-function-alist)
1450                 (setq protocol (mm-handle-media-type (car parts))
1451                       parts nil)
1452               (setq parts (cdr parts))))))
1453       (setq func (nth 1 (assoc protocol mm-decrypt-function-alist)))
1454       (when (cond
1455              ((eq mm-decrypt-option 'never) nil)
1456              ((eq mm-decrypt-option 'always) t)
1457              ((eq mm-decrypt-option 'known)
1458               (and func
1459                    (or (not (setq functest
1460                                   (nth 3 (assoc protocol
1461                                                 mm-decrypt-function-alist))))
1462                        (funcall functest parts ctl))))
1463              (t
1464               (y-or-n-p
1465                (format "Decrypt (%s) part? "
1466                        (or (nth 2 (assoc protocol mm-decrypt-function-alist))
1467                            (format "protocol=%s" protocol))))))
1468         (save-excursion
1469           (if func
1470               (setq parts (funcall func parts ctl))
1471             (mm-set-handle-multipart-parameter
1472              mm-security-handle 'gnus-details
1473              (format "Unknown encrypt protocol (%s)" protocol))))))
1474      (t nil))
1475     parts))
1476
1477 (defun mm-multiple-handles (handles)
1478   (and (listp handles)
1479        (> (length handles) 1)
1480        (or (listp (car handles))
1481            (stringp (car handles)))))
1482
1483 (defun mm-complicated-handles (handles)
1484   (and (listp (car handles))
1485        (> (length handles) 1)))
1486
1487 (defun mm-merge-handles (handles1 handles2)
1488   (append
1489    (if (listp (car handles1))
1490        handles1
1491      (list handles1))
1492    (if (listp (car handles2))
1493        handles2
1494      (list handles2))))
1495
1496 (defun mm-readable-p (handle)
1497   "Say whether the content of HANDLE is readable."
1498   (and (< (with-current-buffer (mm-handle-buffer handle)
1499             (buffer-size)) 10000)
1500        (mm-with-unibyte-buffer
1501          (mm-insert-part handle)
1502          (and (eq (mm-body-7-or-8) '7bit)
1503               (not (mm-long-lines-p 76))))))
1504
1505 (provide 'mm-decode)
1506
1507 ;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b
1508 ;;; mm-decode.el ends here