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

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