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