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