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