lisp/gnus/mm-decode.el

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