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, 2008 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 description
 575               (setq description (mail-decode-encoded-word-string
 576                                  description)))))
 577       (if (or (not ctl)
 578               (not (string-match "/" (car ctl))))
 579           (mm-dissect-singlepart
 580            (list mm-dissect-default-type)
 581            (and cte (intern (downcase (mail-header-strip cte))))
 582            no-strict-mime
 583            (and cd (mail-header-parse-content-disposition cd))
 584            description)
 585         (setq type (split-string (car ctl) "/"))
 586         (setq subtype (cadr type)
 587               type (car type))
 588         (setq
 589          result
 590          (cond
 591           ((equal type "multipart")
 592            (let ((mm-dissect-default-type (if (equal subtype "digest")
 593                                               "message/rfc822"
 594                                             "text/plain"))
 595                  (start (cdr (assq 'start (cdr ctl)))))
 596              (add-text-properties 0 (length (car ctl))
 597                                   (mm-alist-to-plist (cdr ctl)) (car ctl))
 598
 599              ;; what really needs to be done here is a way to link a
 600              ;; MIME handle back to it's parent MIME handle (in a multilevel
 601              ;; MIME article).  That would probably require changing
 602              ;; the mm-handle API so we simply store the multipart buffer
 603              ;; name as a text property of the "multipart/whatever" string.
 604              (add-text-properties 0 (length (car ctl))
 605                                   (list 'buffer (mm-copy-to-buffer)
 606                                         'from from
 607                                         'start start)
 608                                   (car ctl))
 609              (cons (car ctl) (mm-dissect-multipart ctl from))))
 610           (t
 611            (mm-possibly-verify-or-decrypt
 612             (mm-dissect-singlepart
 613              ctl
 614              (and cte (intern (downcase (mail-header-strip cte))))
 615              no-strict-mime
 616              (and cd (mail-header-parse-content-disposition cd))
 617              description id)
 618             ctl))))
 619         (when id
 620           (when (string-match " *<\\(.*\\)> *" id)
 621             (setq id (match-string 1 id)))
 622           (push (cons id result) mm-content-id-alist))
 623         result))))
 624
 625 (defun mm-dissect-singlepart (ctl cte &optional force cdl description id)
 626   (when (or force
 627             (if (equal "text/plain" (car ctl))
 628                 (assoc 'format ctl)
 629               t))
 630     (mm-make-handle
 631      (mm-copy-to-buffer) ctl cte nil cdl description nil id)))
 632
 633 (defun mm-dissect-multipart (ctl from)
 634   (goto-char (point-min))
 635   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 636          (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
 637          start parts
 638          (end (save-excursion
 639                 (goto-char (point-max))
 640                 (if (re-search-backward close-delimiter nil t)
 641                     (match-beginning 0)
 642                   (point-max)))))
 643     (setq boundary (concat (regexp-quote boundary) "[ \t]*$"))
 644     (while (and (< (point) end) (re-search-forward boundary end t))
 645       (goto-char (match-beginning 0))
 646       (when start
 647         (save-excursion
 648           (save-restriction
 649             (narrow-to-region start (point))
 650             (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
 651       (end-of-line 2)
 652       (or (looking-at boundary)
 653           (forward-line 1))
 654       (setq start (point)))
 655     (when (and start (< start end))
 656       (save-excursion
 657         (save-restriction
 658           (narrow-to-region start end)
 659           (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
 660     (mm-possibly-verify-or-decrypt (nreverse parts) ctl)))
 661
 662 (defun mm-copy-to-buffer ()
 663   "Copy the contents of the current buffer to a fresh buffer."
 664     (let ((obuf (current-buffer))
 665           beg)
 666       (goto-char (point-min))
 667       (search-forward-regexp "^\n" nil t)
 668       (setq beg (point))
 669     (with-current-buffer
 670        ;; Preserve the data's unibyteness (for url-insert-file-contents).
 671        (let ((default-enable-multibyte-characters (mm-multibyte-p)))
 672           (generate-new-buffer " *mm*"))
 673       (insert-buffer-substring obuf beg)
 674       (current-buffer))))
 675
 676 (defun mm-display-parts (handle &optional no-default)
 677   (if (stringp (car handle))
 678       (mapcar 'mm-display-parts (cdr handle))
 679     (if (bufferp (car handle))
 680         (save-restriction
 681           (narrow-to-region (point) (point))
 682           (mm-display-part handle)
 683           (goto-char (point-max)))
 684       (mapcar 'mm-display-parts handle))))
 685
 686 (defun mm-display-part (handle &optional no-default)
 687   "Display the MIME part represented by HANDLE.
 688 Returns nil if the part is removed; inline if displayed inline;
 689 external if displayed external."
 690   (save-excursion
 691     (mailcap-parse-mailcaps)
 692     (if (mm-handle-displayed-p handle)
 693         (mm-remove-part handle)
 694       (let* ((ehandle (if (equal (mm-handle-media-type handle)
 695                                  "message/external-body")
 696                           (progn
 697                             (unless (mm-handle-cache handle)
 698                               (mm-extern-cache-contents handle))
 699                             (mm-handle-cache handle))
 700                         handle))
 701              (type (mm-handle-media-type ehandle))
 702              (method (mailcap-mime-info type))
 703              (filename (or (mail-content-type-get
 704                             (mm-handle-disposition handle) 'filename)
 705                            (mail-content-type-get
 706                             (mm-handle-type handle) 'name)
 707                            "<file>"))
 708              (external mm-enable-external))
 709         (if (and (mm-inlinable-p ehandle)
 710                  (mm-inlined-p ehandle))
 711             (progn
 712               (forward-line 1)
 713               (mm-display-inline handle)
 714               'inline)
 715           (when (or method
 716                     (not no-default))
 717             (if (and (not method)
 718                      (equal "text" (car (split-string type "/"))))
 719                 (progn
 720                   (forward-line 1)
 721                   (mm-insert-inline handle (mm-get-part handle))
 722                   'inline)
 723               (setq external
 724                     (and method ;; If nil, we always use "save".
 725                        (stringp method) ;; 'mailcap-save-binary-file
 726                        (or (eq mm-enable-external t)
 727                            (and (eq mm-enable-external 'ask)
 728                                 (y-or-n-p
 729                                  (concat
 730                                   "Display part (" type
 731                                   ") using external program"
 732                                   ;; Can non-string method ever happen?
 733                                   (if (stringp method)
 734                                       (concat
 735                                        " \"" (format method filename) "\"")
 736                                     "")
 737                                     "? "))))))
 738               (if external
 739                   (mm-display-external
 740                    handle (or method 'mailcap-save-binary-file))
 741                 (mm-display-external
 742                  handle 'mailcap-save-binary-file)))))))))
 743
 744 (declare-function gnus-configure-windows "gnus-win" (setting &optional force))
 745
 746 (defun mm-display-external (handle method)
 747   "Display HANDLE using METHOD."
 748   (let ((outbuf (current-buffer)))
 749     (mm-with-unibyte-buffer
 750       (if (functionp method)
 751           (let ((cur (current-buffer)))
 752             (if (eq method 'mailcap-save-binary-file)
 753                 (progn
 754                   (set-buffer (generate-new-buffer " *mm*"))
 755                   (setq method nil))
 756               (mm-insert-part handle)
 757               (mm-add-meta-html-tag handle)
 758               (let ((win (get-buffer-window cur t)))
 759                 (when win
 760                   (select-window win)))
 761               (switch-to-buffer (generate-new-buffer " *mm*")))
 762             (buffer-disable-undo)
 763             (mm-set-buffer-file-coding-system mm-binary-coding-system)
 764             (insert-buffer-substring cur)
 765             (goto-char (point-min))
 766             (when method
 767               (message "Viewing with %s" method))
 768             (let ((mm (current-buffer))
 769                   (non-viewer (assq 'non-viewer
 770                                     (mailcap-mime-info
 771                                      (mm-handle-media-type handle) t))))
 772               (unwind-protect
 773                   (if method
 774                       (funcall method)
 775                     (mm-save-part handle))
 776                 (when (and (not non-viewer)
 777                            method)
 778                   (mm-handle-set-undisplayer handle mm)))))
 779         ;; The function is a string to be executed.
 780         (mm-insert-part handle)
 781         (mm-add-meta-html-tag handle)
 782         (let* ((dir (mm-make-temp-file
 783                      (expand-file-name "emm." mm-tmp-directory) 'dir))
 784                (filename (or
 785                           (mail-content-type-get
 786                            (mm-handle-disposition handle) 'filename)
 787                           (mail-content-type-get
 788                            (mm-handle-type handle) 'name)))
 789                (mime-info (mailcap-mime-info
 790                            (mm-handle-media-type handle) t))
 791                (needsterm (or (assoc "needsterm" mime-info)
 792                               (assoc "needsterminal" mime-info)))
 793                (copiousoutput (assoc "copiousoutput" mime-info))
 794                file buffer)
 795           ;; We create a private sub-directory where we store our files.
 796           (set-file-modes dir 448)
 797           (if filename
 798               (setq file (expand-file-name
 799                           (gnus-map-function mm-file-name-rewrite-functions
 800                                              (file-name-nondirectory filename))
 801                           dir))
 802             ;; Use nametemplate (defined in RFC1524) if it is specified
 803             ;; in mailcap.
 804             (let ((suffix (cdr (assoc "nametemplate" mime-info))))
 805               (if (and suffix
 806                        (string-match "\\`%s\\(\\..+\\)\\'" suffix))
 807                   (setq suffix (match-string 1 suffix))
 808                 ;; Otherwise, use a suffix according to
 809                 ;; `mailcap-mime-extensions'.
 810                 (setq suffix (car (rassoc (mm-handle-media-type handle)
 811                                           mailcap-mime-extensions))))
 812               (setq file (mm-make-temp-file (expand-file-name "mm." dir)
 813                                             nil suffix))))
 814           (let ((coding-system-for-write mm-binary-coding-system))
 815             (write-region (point-min) (point-max) file nil 'nomesg))
 816           (message "Viewing with %s" method)
 817           (cond
 818            (needsterm
 819             (let ((command (mm-mailcap-command
 820                             method file (mm-handle-type handle))))
 821               (unwind-protect
 822                   (if window-system
 823                       (start-process "*display*" nil
 824                                      mm-external-terminal-program
 825                                      "-e" shell-file-name
 826                                      shell-command-switch command)
 827                     (require 'term)
 828                     (require 'gnus-win)
 829                     (set-buffer
 830                      (setq buffer
 831                            (make-term "display"
 832                                       shell-file-name
 833                                       nil
 834                                       shell-command-switch command)))
 835                     (term-mode)
 836                     (term-char-mode)
 837                     (set-process-sentinel
 838                      (get-buffer-process buffer)
 839                      `(lambda (process state)
 840                         (if (eq 'exit (process-status process))
 841                             (gnus-configure-windows
 842                              ',gnus-current-window-configuration))))
 843                     (gnus-configure-windows 'display-term))
 844                 (mm-handle-set-external-undisplayer handle (cons file buffer)))
 845               (message "Displaying %s..." command))
 846             'external)
 847            (copiousoutput
 848             (with-current-buffer outbuf
 849               (forward-line 1)
 850               (mm-insert-inline
 851                handle
 852                (unwind-protect
 853                    (progn
 854                      (call-process shell-file-name nil
 855                                    (setq buffer
 856                                          (generate-new-buffer " *mm*"))
 857                                    nil
 858                                    shell-command-switch
 859                                    (mm-mailcap-command
 860                                     method file (mm-handle-type handle)))
 861                      (if (buffer-live-p buffer)
 862                          (with-current-buffer buffer
 863                            (buffer-string))))
 864                  (progn
 865                    (ignore-errors (delete-file file))
 866                    (ignore-errors (delete-directory
 867                                    (file-name-directory file)))
 868                    (ignore-errors (kill-buffer buffer))))))
 869             'inline)
 870            (t
 871             ;; Deleting the temp file should be postponed for some wrappers,
 872             ;; shell scripts, and so on, which might exit right after having
 873             ;; started a viewer command as a background job.
 874             (let ((command (mm-mailcap-command
 875                             method file (mm-handle-type handle))))
 876               (unwind-protect
 877                   (progn
 878                     (start-process "*display*"
 879                                    (setq buffer
 880                                          (generate-new-buffer " *mm*"))
 881                                    shell-file-name
 882                                    shell-command-switch command)
 883                     (set-process-sentinel
 884                      (get-buffer-process buffer)
 885                      (lexical-let ;; Don't use `let'.
 886                          ;; Function used to remove temp file and directory.
 887                          ((fn `(lambda nil
 888                                  ;; Don't use `ignore-errors'.
 889                                  (condition-case nil
 890                                      (delete-file ,file)
 891                                    (error))
 892                                  (condition-case nil
 893                                      (delete-directory
 894                                       ,(file-name-directory file))
 895                                    (error))))
 896                           ;; Form uses to kill the process buffer and
 897                           ;; remove the undisplayer.
 898                           (fm `(progn
 899                                  (kill-buffer ,buffer)
 900                                  ,(macroexpand
 901                                    (list 'mm-handle-set-undisplayer
 902                                          (list 'quote handle)
 903                                          nil))))
 904                           ;; Message to be issued when the process exits.
 905                           (done (format "Displaying %s...done" command))
 906                           ;; In particular, the timer object (which is
 907                           ;; a vector in Emacs but is a list in XEmacs)
 908                           ;; requires that it is lexically scoped.
 909                           (timer (run-at-time 2.0 nil 'ignore)))
 910                        (if (featurep 'xemacs)
 911                            (lambda (process state)
 912                              (when (eq 'exit (process-status process))
 913                                (if (memq timer itimer-list)
 914                                    (set-itimer-function timer fn)
 915                                  (funcall fn))
 916                                (ignore-errors (eval fm))
 917                                (message "%s" done)))
 918                          (lambda (process state)
 919                            (when (eq 'exit (process-status process))
 920                              (if (memq timer timer-list)
 921                                  (timer-set-function timer fn)
 922                                (funcall fn))
 923                              (ignore-errors (eval fm))
 924                              (message "%s" done)))))))
 925                 (mm-handle-set-external-undisplayer
 926                  handle (cons file buffer)))
 927               (message "Displaying %s..." command))
 928             'external)))))))
 929
 930 (defun mm-mailcap-command (method file type-list)
 931   (let ((ctl (cdr type-list))
 932         (beg 0)
 933         (uses-stdin t)
 934         out sub total)
 935     (while (string-match "%{\\([^}]+\\)}\\|'%s'\\|\"%s\"\\|%s\\|%t\\|%%"
 936                          method beg)
 937       (push (substring method beg (match-beginning 0)) out)
 938       (setq beg (match-end 0)
 939             total (match-string 0 method)
 940             sub (match-string 1 method))
 941       (cond
 942        ((string= total "%%")
 943         (push "%" out))
 944        ((or (string= total "%s")
 945             ;; We do our own quoting.
 946             (string= total "'%s'")
 947             (string= total "\"%s\""))
 948         (setq uses-stdin nil)
 949         (push (shell-quote-argument
 950                (gnus-map-function mm-path-name-rewrite-functions file)) out))
 951        ((string= total "%t")
 952         (push (shell-quote-argument (car type-list)) out))
 953        (t
 954         (push (shell-quote-argument (or (cdr (assq (intern sub) ctl)) "")) out))))
 955     (push (substring method beg (length method)) out)
 956     (when uses-stdin
 957       (push "<" out)
 958       (push (shell-quote-argument
 959              (gnus-map-function mm-path-name-rewrite-functions file))
 960             out))
 961     (mapconcat 'identity (nreverse out) "")))
 962
 963 (defun mm-remove-parts (handles)
 964   "Remove the displayed MIME parts represented by HANDLES."
 965   (if (and (listp handles)
 966            (bufferp (car handles)))
 967       (mm-remove-part handles)
 968     (let (handle)
 969       (while (setq handle (pop handles))
 970         (cond
 971          ((stringp handle)
 972           (when (buffer-live-p (get-text-property 0 'buffer handle))
 973             (kill-buffer (get-text-property 0 'buffer handle))))
 974          ((and (listp handle)
 975                (stringp (car handle)))
 976           (mm-remove-parts (cdr handle)))
 977          (t
 978           (mm-remove-part handle)))))))
 979
 980 (defun mm-destroy-parts (handles)
 981   "Remove the displayed MIME parts represented by HANDLES."
 982   (if (and (listp handles)
 983            (bufferp (car handles)))
 984       (mm-destroy-part handles)
 985     (let (handle)
 986       (while (setq handle (pop handles))
 987         (cond
 988          ((stringp handle)
 989           (when (buffer-live-p (get-text-property 0 'buffer handle))
 990             (kill-buffer (get-text-property 0 'buffer handle))))
 991          ((and (listp handle)
 992                (stringp (car handle)))
 993           (mm-destroy-parts handle))
 994          (t
 995           (mm-destroy-part handle)))))))
 996
 997 (defun mm-remove-part (handle)
 998   "Remove the displayed MIME part represented by HANDLE."
 999   (when (listp handle)
1000     (let ((object (mm-handle-undisplayer handle)))
1001       (ignore-errors
1002         (cond
1003          ;; Internally displayed part.
1004          ((mm-annotationp object)
1005           (if (featurep 'xemacs)
1006               (delete-annotation object)))
1007          ((or (functionp object)
1008               (and (listp object)
1009                    (eq (car object) 'lambda)))
1010           (funcall object))
1011          ;; Externally displayed part.
1012          ((consp object)
1013           (condition-case ()
1014               (while (get-buffer-process (cdr object))
1015                 (interrupt-process (get-buffer-process (cdr object)))
1016                 (message "Waiting for external displayer to die...")
1017                 (sit-for 1))
1018             (quit)
1019             (error))
1020           (ignore-errors (and (cdr object) (kill-buffer (cdr object))))
1021           (message "Waiting for external displayer to die...done")
1022           (ignore-errors (delete-file (car object)))
1023           (ignore-errors (delete-directory (file-name-directory
1024                                             (car object)))))
1025          ((bufferp object)
1026           (when (buffer-live-p object)
1027             (kill-buffer object)))))
1028       (mm-handle-set-undisplayer handle nil))))
1029
1030 (defun mm-display-inline (handle)
1031   (let* ((type (mm-handle-media-type handle))
1032          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
1033     (funcall function handle)
1034     (goto-char (point-min))))
1035
1036 (defun mm-assoc-string-match (alist type)
1037   (dolist (elem alist)
1038     (when (string-match (car elem) type)
1039       (return elem))))
1040
1041 (defun mm-automatic-display-p (handle)
1042   "Say whether the user wants HANDLE to be displayed automatically."
1043   (let ((methods mm-automatic-display)
1044         (type (mm-handle-media-type handle))
1045         method result)
1046     (while (setq method (pop methods))
1047       (when (and (not (mm-inline-override-p handle))
1048                  (string-match method type))
1049         (setq result t
1050               methods nil)))
1051     result))
1052
1053 (defun mm-inlinable-p (handle &optional type)
1054   "Say whether HANDLE can be displayed inline.
1055 TYPE is the mime-type of the object; it defaults to the one given
1056 in HANDLE."
1057   (unless type (setq type (mm-handle-media-type handle)))
1058   (let ((alist mm-inline-media-tests)
1059         test)
1060     (while alist
1061       (when (string-match (caar alist) type)
1062         (setq test (caddar alist)
1063               alist nil)
1064         (setq test (funcall test handle)))
1065       (pop alist))
1066     test))
1067
1068 (defun mm-inlined-p (handle)
1069   "Say whether the user wants HANDLE to be displayed inline."
1070   (let ((methods mm-inlined-types)
1071         (type (mm-handle-media-type handle))
1072         method result)
1073     (while (setq method (pop methods))
1074       (when (and (not (mm-inline-override-p handle))
1075                  (string-match method type))
1076         (setq result t
1077               methods nil)))
1078     result))
1079
1080 (defun mm-attachment-override-p (handle)
1081   "Say whether HANDLE should have attachment behavior overridden."
1082   (let ((types mm-attachment-override-types)
1083         (type (mm-handle-media-type handle))
1084         ty)
1085     (catch 'found
1086       (while (setq ty (pop types))
1087         (when (and (string-match ty type)
1088                    (mm-inlinable-p handle))
1089           (throw 'found t))))))
1090
1091 (defun mm-inline-override-p (handle)
1092   "Say whether HANDLE should have inline behavior overridden."
1093   (let ((types mm-inline-override-types)
1094         (type (mm-handle-media-type handle))
1095         ty)
1096     (catch 'found
1097       (while (setq ty (pop types))
1098         (when (string-match ty type)
1099           (throw 'found t))))))
1100
1101 (defun mm-automatic-external-display-p (type)
1102   "Return the user-defined method for TYPE."
1103   (let ((methods mm-automatic-external-display)
1104         method result)
1105     (while (setq method (pop methods))
1106       (when (string-match method type)
1107         (setq result t
1108               methods nil)))
1109     result))
1110
1111 (defun mm-destroy-part (handle)
1112   "Destroy the data structures connected to HANDLE."
1113   (when (listp handle)
1114     (mm-remove-part handle)
1115     (when (buffer-live-p (mm-handle-buffer handle))
1116       (kill-buffer (mm-handle-buffer handle)))))
1117
1118 (defun mm-handle-displayed-p (handle)
1119   "Say whether HANDLE is displayed or not."
1120   (mm-handle-undisplayer handle))
1121
1122 ;;;
1123 ;;; Functions for outputting parts
1124 ;;;
1125
1126 (defmacro mm-with-part (handle &rest forms)
1127   "Run FORMS in the temp buffer containing the contents of HANDLE."
1128   `(let* ((handle ,handle)
1129           ;; The multibyteness of the temp buffer should be turned on
1130           ;; if inserting a multibyte string.  Contrarily, the buffer's
1131           ;; multibyteness should be off if inserting a unibyte string,
1132           ;; especially if a string contains 8bit data.
1133           (default-enable-multibyte-characters
1134             (with-current-buffer (mm-handle-buffer handle)
1135               (mm-multibyte-p))))
1136      (with-temp-buffer
1137        (insert-buffer-substring (mm-handle-buffer handle))
1138        (mm-disable-multibyte)
1139        (mm-decode-content-transfer-encoding
1140         (mm-handle-encoding handle)
1141         (mm-handle-media-type handle))
1142        ,@forms)))
1143 (put 'mm-with-part 'lisp-indent-function 1)
1144 (put 'mm-with-part 'edebug-form-spec '(body))
1145
1146 (defun mm-get-part (handle &optional no-cache)
1147   "Return the contents of HANDLE as a string.
1148 If NO-CACHE is non-nil, cached contents of a message/external-body part
1149 are ignored."
1150   (if (and (not no-cache)
1151            (equal (mm-handle-media-type handle) "message/external-body"))
1152       (progn
1153         (unless (mm-handle-cache handle)
1154           (mm-extern-cache-contents handle))
1155         (with-current-buffer (mm-handle-buffer (mm-handle-cache handle))
1156           (buffer-string)))
1157     (mm-with-part handle
1158       (buffer-string))))
1159
1160 (defun mm-insert-part (handle &optional no-cache)
1161   "Insert the contents of HANDLE in the current buffer.
1162 If NO-CACHE is non-nil, cached contents of a message/external-body part
1163 are ignored."
1164   (let ((text (cond ((eq (mail-content-type-get (mm-handle-type handle)
1165                                                 'charset)
1166                          'gnus-decoded)
1167                      (with-current-buffer (mm-handle-buffer handle)
1168                        (buffer-string)))
1169                     ((mm-multibyte-p)
1170                      (mm-string-to-multibyte (mm-get-part handle no-cache)))
1171                     (t
1172                      (mm-get-part handle no-cache)))))
1173     (save-restriction
1174       (widen)
1175       (goto-char
1176        (prog1
1177            (point)
1178          (if (and (eq (get-char-property (max (point-min) (1- (point))) 'face)
1179                       'mm-uu-extract)
1180                   (eq (get-char-property 0 'face text) 'mm-uu-extract))
1181              ;; Separate the extracted parts that have the same faces.
1182              (insert "\n" text)
1183            (insert text)))))))
1184
1185 (defun mm-file-name-delete-whitespace (file-name)
1186   "Remove all whitespace characters from FILE-NAME."
1187   (while (string-match "\\s-+" file-name)
1188     (setq file-name (replace-match "" t t file-name)))
1189   file-name)
1190
1191 (defun mm-file-name-trim-whitespace (file-name)
1192   "Remove leading and trailing whitespace characters from FILE-NAME."
1193   (when (string-match "\\`\\s-+" file-name)
1194     (setq file-name (substring file-name (match-end 0))))
1195   (when (string-match "\\s-+\\'" file-name)
1196     (setq file-name (substring file-name 0 (match-beginning 0))))
1197   file-name)
1198
1199 (defun mm-file-name-collapse-whitespace (file-name)
1200   "Collapse multiple whitespace characters in FILE-NAME."
1201   (while (string-match "\\s-\\s-+" file-name)
1202     (setq file-name (replace-match " " t t file-name)))
1203   file-name)
1204
1205 (defun mm-file-name-replace-whitespace (file-name)
1206   "Replace whitespace characters in FILE-NAME with underscores.
1207 Set the option `mm-file-name-replace-whitespace' to any other
1208 string if you do not like underscores."
1209   (let ((s (or mm-file-name-replace-whitespace "_")))
1210     (while (string-match "\\s-" file-name)
1211       (setq file-name (replace-match s t t file-name))))
1212   file-name)
1213
1214 (defun mm-file-name-delete-control (filename)
1215   "Delete control characters from FILENAME."
1216   (gnus-replace-in-string filename "[\x00-\x1f\x7f]" ""))
1217
1218 (defun mm-file-name-delete-gotchas (filename)
1219   "Delete shell gotchas from FILENAME."
1220   (setq filename (gnus-replace-in-string filename "[<>|]" ""))
1221   (gnus-replace-in-string filename "^[.-]+" ""))
1222
1223 (defun mm-save-part (handle &optional prompt)
1224   "Write HANDLE to a file.
1225 PROMPT overrides the default one used to ask user for a file name."
1226   (let ((filename (or (mail-content-type-get
1227                        (mm-handle-disposition handle) 'filename)
1228                       (mail-content-type-get
1229                        (mm-handle-type handle) 'name)))
1230         file)
1231     (when filename
1232       (setq filename (gnus-map-function mm-file-name-rewrite-functions
1233                                         (file-name-nondirectory filename))))
1234     (setq file
1235           (mm-with-multibyte
1236            (read-file-name (or prompt "Save MIME part to: ")
1237                            (or mm-default-directory default-directory)
1238                            nil nil (or filename ""))))
1239     (setq mm-default-directory (file-name-directory file))
1240     (and (or (not (file-exists-p file))
1241              (yes-or-no-p (format "File %s already exists; overwrite? "
1242                                   file)))
1243          (progn
1244            (mm-save-part-to-file handle file)
1245            file))))
1246
1247 (defun mm-add-meta-html-tag (handle &optional charset)
1248   "Add meta html tag to specify CHARSET of HANDLE in the current buffer.
1249 CHARSET defaults to the one HANDLE specifies.  Existing meta tag that
1250 specifies charset will not be modified.  Return t if meta tag is added
1251 or replaced."
1252   (when (equal (mm-handle-media-type handle) "text/html")
1253     (when (or charset
1254               (setq charset (mail-content-type-get (mm-handle-type handle)
1255                                                    'charset)))
1256       (setq charset (format "\
1257 <meta http-equiv=\"Content-Type\" content=\"text/html; charset=%s\">" charset))
1258       (let ((case-fold-search t))
1259         (goto-char (point-min))
1260         (if (re-search-forward "\
1261 <meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']\
1262 text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+?\\)\\)?[\"'][^>]*>" nil t)
1263             (if (and (match-beginning 2)
1264                      (string-match "\\`html\\'" (match-string 1)))
1265                 ;; Don't modify existing meta tag.
1266                 nil
1267               ;; Replace it with the one specifying charset.
1268               (replace-match charset)
1269               t)
1270           (if (re-search-forward "<head>\\s-*" nil t)
1271               (insert charset "\n")
1272             (re-search-forward "<html\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t)
1273             (insert "<head>\n" charset "\n</head>\n"))
1274           t)))))
1275
1276 (defun mm-save-part-to-file (handle file)
1277   (mm-with-unibyte-buffer
1278     (mm-insert-part handle)
1279     (mm-add-meta-html-tag handle)
1280     (let ((current-file-modes (default-file-modes)))
1281       (set-default-file-modes mm-attachment-file-modes)
1282       (unwind-protect
1283           ;; Don't re-compress .gz & al.  Arguably we should make
1284           ;; `file-name-handler-alist' nil, but that would chop
1285           ;; ange-ftp, which is reasonable to use here.
1286           (mm-write-region (point-min) (point-max) file nil nil nil 'binary t)
1287         (set-default-file-modes current-file-modes)))))
1288
1289 (defun mm-pipe-part (handle)
1290   "Pipe HANDLE to a process."
1291   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
1292          (command
1293           (read-string "Shell command on MIME part: " mm-last-shell-command)))
1294     (mm-with-unibyte-buffer
1295       (mm-insert-part handle)
1296       (mm-add-meta-html-tag handle)
1297       (let ((coding-system-for-write 'binary))
1298         (shell-command-on-region (point-min) (point-max) command nil)))))
1299
1300 (defun mm-interactively-view-part (handle)
1301   "Display HANDLE using METHOD."
1302   (let* ((type (mm-handle-media-type handle))
1303          (methods
1304           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
1305                   (mailcap-mime-info type 'all)))
1306          (method (let ((minibuffer-local-completion-map
1307                         mm-viewer-completion-map))
1308                    (completing-read "Viewer: " methods))))
1309     (when (string= method "")
1310       (error "No method given"))
1311     (if (string-match "^[^% \t]+$" method)
1312         (setq method (concat method " %s")))
1313     (mm-display-external handle method)))
1314
1315 (defun mm-preferred-alternative (handles &optional preferred)
1316   "Say which of HANDLES are preferred."
1317   (let ((prec (if preferred (list preferred)
1318                 (mm-preferred-alternative-precedence handles)))
1319         p h result type handle)
1320     (while (setq p (pop prec))
1321       (setq h handles)
1322       (while h
1323         (setq handle (car h))
1324         (setq type (mm-handle-media-type handle))
1325         (when (and (equal p type)
1326                    (mm-automatic-display-p handle)
1327                    (or (stringp (car handle))
1328                        (not (mm-handle-disposition handle))
1329                        (equal (car (mm-handle-disposition handle))
1330                               "inline")))
1331           (setq result handle
1332                 h nil
1333                 prec nil))
1334         (pop h)))
1335     result))
1336
1337 (defun mm-preferred-alternative-precedence (handles)
1338   "Return the precedence based on HANDLES and `mm-discouraged-alternatives'."
1339   (let ((seq (nreverse (mapcar #'mm-handle-media-type
1340                                handles))))
1341     (dolist (disc (reverse mm-discouraged-alternatives))
1342       (dolist (elem (copy-sequence seq))
1343         (when (string-match disc elem)
1344           (setq seq (nconc (delete elem seq) (list elem))))))
1345     seq))
1346
1347 (defun mm-get-content-id (id)
1348   "Return the handle(s) referred to by ID."
1349   (cdr (assoc id mm-content-id-alist)))
1350
1351 (defconst mm-image-type-regexps
1352   '(("/\\*.*XPM.\\*/" . xpm)
1353     ("P[1-6]" . pbm)
1354     ("GIF8" . gif)
1355     ("\377\330" . jpeg)
1356     ("\211PNG\r\n" . png)
1357     ("#define" . xbm)
1358     ("\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff)
1359     ("%!PS" . postscript))
1360   "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types.
1361 When the first bytes of an image file match REGEXP, it is assumed to
1362 be of image type IMAGE-TYPE.")
1363
1364 ;; Steal from image.el. image-type-from-data suffers multi-line matching bug.
1365 (defun mm-image-type-from-buffer ()
1366   "Determine the image type from data in the current buffer.
1367 Value is a symbol specifying the image type or nil if type cannot
1368 be determined."
1369   (let ((types mm-image-type-regexps)
1370         type)
1371     (goto-char (point-min))
1372     (while (and types (null type))
1373       (let ((regexp (car (car types)))
1374             (image-type (cdr (car types))))
1375         (when (looking-at regexp)
1376           (setq type image-type))
1377         (setq types (cdr types))))
1378     type))
1379
1380 (defun mm-get-image (handle)
1381   "Return an image instance based on HANDLE."
1382   (let ((type (mm-handle-media-subtype handle))
1383         spec)
1384     ;; Allow some common translations.
1385     (setq type
1386           (cond
1387            ((equal type "x-pixmap")
1388             "xpm")
1389            ((equal type "x-xbitmap")
1390             "xbm")
1391            ((equal type "x-portable-bitmap")
1392             "pbm")
1393            (t type)))
1394     (or (mm-handle-cache handle)
1395         (mm-with-unibyte-buffer
1396           (mm-insert-part handle)
1397           (prog1
1398               (setq spec
1399                     (ignore-errors
1400                       ;; Avoid testing `make-glyph' since W3 may define
1401                       ;; a bogus version of it.
1402                       (if (fboundp 'create-image)
1403                           (create-image (buffer-string)
1404                                         (or (mm-image-type-from-buffer)
1405                                             (intern type))
1406                                         'data-p)
1407                         (mm-create-image-xemacs type))))
1408             (mm-handle-set-cache handle spec))))))
1409
1410 (defun mm-create-image-xemacs (type)
1411   (when (featurep 'xemacs)
1412     (cond
1413      ((equal type "xbm")
1414       ;; xbm images require special handling, since
1415       ;; the only way to create glyphs from these
1416       ;; (without a ton of work) is to write them
1417       ;; out to a file, and then create a file
1418       ;; specifier.
1419       (let ((file (mm-make-temp-file
1420                    (expand-file-name "emm" mm-tmp-directory)
1421                    nil ".xbm")))
1422         (unwind-protect
1423             (progn
1424               (write-region (point-min) (point-max) file)
1425               (make-glyph (list (cons 'x file))))
1426           (ignore-errors
1427             (delete-file file)))))
1428      (t
1429       (make-glyph
1430        (vector
1431         (or (mm-image-type-from-buffer)
1432             (intern type))
1433         :data (buffer-string)))))))
1434
1435 (defun mm-image-fit-p (handle)
1436   "Say whether the image in HANDLE will fit the current window."
1437   (let ((image (mm-get-image handle)))
1438     (or (not image)
1439         (if (featurep 'xemacs)
1440             ;; XEmacs' glyphs can actually tell us about their width, so
1441             ;; lets be nice and smart about them.
1442             (or mm-inline-large-images
1443                 (and (<= (glyph-width image) (window-pixel-width))
1444                      (<= (glyph-height image) (window-pixel-height))))
1445           (let* ((size (image-size image))
1446                  (w (car size))
1447                  (h (cdr size)))
1448             (or mm-inline-large-images
1449                 (and (<= h (1- (window-height))) ; Don't include mode line.
1450                      (<= w (window-width)))))))))
1451
1452 (defun mm-valid-image-format-p (format)
1453   "Say whether FORMAT can be displayed natively by Emacs."
1454   (cond
1455    ;; Handle XEmacs
1456    ((fboundp 'valid-image-instantiator-format-p)
1457     (valid-image-instantiator-format-p format))
1458    ;; Handle Emacs 21
1459    ((fboundp 'image-type-available-p)
1460     (and (display-graphic-p)
1461          (image-type-available-p format)))
1462    ;; Nobody else can do images yet.
1463    (t
1464     nil)))
1465
1466 (defun mm-valid-and-fit-image-p (format handle)
1467   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
1468   (and (mm-valid-image-format-p format)
1469        (mm-image-fit-p handle)))
1470
1471 (defun mm-find-part-by-type (handles type &optional notp recursive)
1472   "Search in HANDLES for part with TYPE.
1473 If NOTP, returns first non-matching part.
1474 If RECURSIVE, search recursively."
1475   (let (handle)
1476     (while handles
1477       (if (and recursive (stringp (caar handles)))
1478           (if (setq handle (mm-find-part-by-type (cdar handles) type
1479                                                  notp recursive))
1480               (setq handles nil))
1481         (if (if notp
1482                 (not (equal (mm-handle-media-type (car handles)) type))
1483               (equal (mm-handle-media-type (car handles)) type))
1484             (setq handle (car handles)
1485                   handles nil)))
1486       (setq handles (cdr handles)))
1487     handle))
1488
1489 (defun mm-find-raw-part-by-type (ctl type &optional notp)
1490   (goto-char (point-min))
1491   (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl
1492                                                                    'boundary)))
1493          (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$"))
1494          start
1495          (end (save-excursion
1496                 (goto-char (point-max))
1497                 (if (re-search-backward close-delimiter nil t)
1498                     (match-beginning 0)
1499                   (point-max))))
1500          result)
1501     (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$"))
1502     (while (and (not result)
1503                 (re-search-forward boundary end t))
1504       (goto-char (match-beginning 0))
1505       (when start
1506         (save-excursion
1507           (save-restriction
1508             (narrow-to-region start (1- (point)))
1509             (when (let* ((ct (mail-fetch-field "content-type"))
1510                          (ctl (and ct (mail-header-parse-content-type ct))))
1511                     (if notp
1512                         (not (equal (car ctl) type))
1513                       (equal (car ctl) type)))
1514               (setq result (buffer-string))))))
1515       (forward-line 1)
1516       (setq start (point)))
1517     (when (and (not result) start)
1518       (save-excursion
1519         (save-restriction
1520           (narrow-to-region start end)
1521           (when (let* ((ct (mail-fetch-field "content-type"))
1522                        (ctl (and ct (mail-header-parse-content-type ct))))
1523                   (if notp
1524                       (not (equal (car ctl) type))
1525                     (equal (car ctl) type)))
1526             (setq result (buffer-string))))))
1527     result))
1528
1529 (defvar mm-security-handle nil)
1530
1531 (defsubst mm-set-handle-multipart-parameter (handle parameter value)
1532   ;; HANDLE could be a CTL.
1533   (when handle
1534     (put-text-property 0 (length (car handle)) parameter value
1535                        (car handle))))
1536
1537 (autoload 'mm-view-pkcs7 "mm-view")
1538
1539 (defun mm-possibly-verify-or-decrypt (parts ctl)
1540   (let ((type (car ctl))
1541         (subtype (cadr (split-string (car ctl) "/")))
1542         (mm-security-handle ctl) ;; (car CTL) is the type.
1543         protocol func functest)
1544     (cond
1545      ((or (equal type "application/x-pkcs7-mime")
1546           (equal type "application/pkcs7-mime"))
1547       (with-temp-buffer
1548         (when (and (cond
1549                     ((eq mm-decrypt-option 'never) nil)
1550                     ((eq mm-decrypt-option 'always) t)
1551                     ((eq mm-decrypt-option 'known) t)
1552                     (t (y-or-n-p
1553                         (format "Decrypt (S/MIME) part? "))))
1554                    (mm-view-pkcs7 parts))
1555           (setq parts (mm-dissect-buffer t)))))
1556      ((equal subtype "signed")
1557       (unless (and (setq protocol
1558                          (mm-handle-multipart-ctl-parameter ctl 'protocol))
1559                    (not (equal protocol "multipart/mixed")))
1560         ;; The message is broken or draft-ietf-openpgp-multsig-01.
1561         (let ((protocols mm-verify-function-alist))
1562           (while protocols
1563             (if (and (or (not (setq functest (nth 3 (car protocols))))
1564                          (funcall functest parts ctl))
1565                      (mm-find-part-by-type parts (caar protocols) nil t))
1566                 (setq protocol (caar protocols)
1567                       protocols nil)
1568               (setq protocols (cdr protocols))))))
1569       (setq func (nth 1 (assoc protocol mm-verify-function-alist)))
1570       (when (cond
1571              ((eq mm-verify-option 'never) nil)
1572              ((eq mm-verify-option 'always) t)
1573              ((eq mm-verify-option 'known)
1574               (and func
1575                    (or (not (setq functest
1576                                   (nth 3 (assoc protocol
1577                                                 mm-verify-function-alist))))
1578                        (funcall functest parts ctl))))
1579              (t
1580               (y-or-n-p
1581                (format "Verify signed (%s) part? "
1582                        (or (nth 2 (assoc protocol mm-verify-function-alist))
1583                            (format "protocol=%s" protocol))))))
1584         (save-excursion
1585           (if func
1586               (setq parts (funcall func parts ctl))
1587             (mm-set-handle-multipart-parameter
1588              mm-security-handle 'gnus-details
1589              (format "Unknown sign protocol (%s)" protocol))))))
1590      ((equal subtype "encrypted")
1591       (unless (setq protocol
1592                     (mm-handle-multipart-ctl-parameter ctl 'protocol))
1593         ;; The message is broken.
1594         (let ((parts parts))
1595           (while parts
1596             (if (assoc (mm-handle-media-type (car parts))
1597                        mm-decrypt-function-alist)
1598                 (setq protocol (mm-handle-media-type (car parts))
1599                       parts nil)
1600               (setq parts (cdr parts))))))
1601       (setq func (nth 1 (assoc protocol mm-decrypt-function-alist)))
1602       (when (cond
1603              ((eq mm-decrypt-option 'never) nil)
1604              ((eq mm-decrypt-option 'always) t)
1605              ((eq mm-decrypt-option 'known)
1606               (and func
1607                    (or (not (setq functest
1608                                   (nth 3 (assoc protocol
1609                                                 mm-decrypt-function-alist))))
1610                        (funcall functest parts ctl))))
1611              (t
1612               (y-or-n-p
1613                (format "Decrypt (%s) part? "
1614                        (or (nth 2 (assoc protocol mm-decrypt-function-alist))
1615                            (format "protocol=%s" protocol))))))
1616         (save-excursion
1617           (if func
1618               (setq parts (funcall func parts ctl))
1619             (mm-set-handle-multipart-parameter
1620              mm-security-handle 'gnus-details
1621              (format "Unknown encrypt protocol (%s)" protocol))))))
1622      (t nil))
1623     parts))
1624
1625 (defun mm-multiple-handles (handles)
1626   (and (listp handles)
1627        (> (length handles) 1)
1628        (or (listp (car handles))
1629            (stringp (car handles)))))
1630
1631 (defun mm-complicated-handles (handles)
1632   (and (listp (car handles))
1633        (> (length handles) 1)))
1634
1635 (defun mm-merge-handles (handles1 handles2)
1636   (append
1637    (if (listp (car handles1))
1638        handles1
1639      (list handles1))
1640    (if (listp (car handles2))
1641        handles2
1642      (list handles2))))
1643
1644 (defun mm-readable-p (handle)
1645   "Say whether the content of HANDLE is readable."
1646   (and (< (with-current-buffer (mm-handle-buffer handle)
1647             (buffer-size)) 10000)
1648        (mm-with-unibyte-buffer
1649          (mm-insert-part handle)
1650          (and (eq (mm-body-7-or-8) '7bit)
1651               (not (mm-long-lines-p 76))))))
1652
1653 (provide 'mm-decode)
1654
1655 ;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b
1656 ;;; mm-decode.el ends here