git.chise.org Git - elisp/gnus.git-/blob - lisp/mm-decode.el

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