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

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