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

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