mm-decode.el 64.8 KB
Newer Older
1
;;; mm-decode.el --- Functions for decoding MIME things
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
Gerd Moellmann's avatar
Gerd Moellmann committed
4 5 6 7 8

;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;;	MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; This file is part of GNU Emacs.

9
;; GNU Emacs is free software: you can redistribute it and/or modify
Gerd Moellmann's avatar
Gerd Moellmann committed
10
;; it under the terms of the GNU General Public License as published by
11 12
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Gerd Moellmann's avatar
Gerd Moellmann committed
13 14 15

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Gerd Moellmann's avatar
Gerd Moellmann committed
17 18 19
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
20
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Gerd Moellmann's avatar
Gerd Moellmann committed
21 22 23 24 25 26 27

;;; Commentary:

;;; Code:

(require 'mail-parse)
(require 'mm-bodies)
28
(eval-when-compile (require 'cl))
Gerd Moellmann's avatar
Gerd Moellmann committed
29

30 31 32
(autoload 'gnus-map-function "gnus-util")
(autoload 'gnus-replace-in-string "gnus-util")
(autoload 'gnus-read-shell-command "gnus-util")
33

Glenn Morris's avatar
Glenn Morris committed
34 35 36 37
(autoload 'mm-inline-partial "mm-partial")
(autoload 'mm-inline-external-body "mm-extern")
(autoload 'mm-extern-cache-contents "mm-extern")
(autoload 'mm-insert-inline "mm-view")
Gerd Moellmann's avatar
Gerd Moellmann committed
38

39 40 41 42
(autoload 'mm-archive-decoders "mm-archive")
(autoload 'mm-archive-dissect-and-inline "mm-archive")
(autoload 'mm-dissect-archive "mm-archive")

43 44
(defvar gnus-current-window-configuration)

45
(add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list)
46
(add-hook 'gnus-exit-gnus-hook 'mm-temp-files-delete)
47

Gerd Moellmann's avatar
Gerd Moellmann committed
48 49
(defgroup mime-display ()
  "Display of MIME in mail and news articles."
50
  :link '(custom-manual "(emacs-mime)Display Customization")
Gerd Moellmann's avatar
Gerd Moellmann committed
51 52 53 54 55
  :version "21.1"
  :group 'mail
  :group 'news
  :group 'multimedia)

56 57 58 59 60 61 62
(defgroup mime-security ()
  "MIME security in mail and news articles."
  :link '(custom-manual "(emacs-mime)Display Customization")
  :group 'mail
  :group 'news
  :group 'multimedia)

63 64 65 66 67 68 69 70 71 72 73 74
(defface mm-command-output
  '((((class color)
      (background dark))
     (:foreground "ForestGreen"))
    (((class color)
      (background light))
     (:foreground "red3"))
    (t
     (:italic t)))
  "Face used for displaying output from commands."
  :group 'mime-display)

Gerd Moellmann's avatar
Gerd Moellmann committed
75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104
;;; Convenience macros.

(defmacro mm-handle-buffer (handle)
  `(nth 0 ,handle))
(defmacro mm-handle-type (handle)
  `(nth 1 ,handle))
(defsubst mm-handle-media-type (handle)
  (if (stringp (car handle))
      (car handle)
    (car (mm-handle-type handle))))
(defsubst mm-handle-media-supertype (handle)
  (car (split-string (mm-handle-media-type handle) "/")))
(defsubst mm-handle-media-subtype (handle)
  (cadr (split-string (mm-handle-media-type handle) "/")))
(defmacro mm-handle-encoding (handle)
  `(nth 2 ,handle))
(defmacro mm-handle-undisplayer (handle)
  `(nth 3 ,handle))
(defmacro mm-handle-set-undisplayer (handle function)
  `(setcar (nthcdr 3 ,handle) ,function))
(defmacro mm-handle-disposition (handle)
  `(nth 4 ,handle))
(defmacro mm-handle-description (handle)
  `(nth 5 ,handle))
(defmacro mm-handle-cache (handle)
  `(nth 6 ,handle))
(defmacro mm-handle-set-cache (handle contents)
  `(setcar (nthcdr 6 ,handle) ,contents))
(defmacro mm-handle-id (handle)
  `(nth 7 ,handle))
105 106 107 108 109 110 111
(defmacro mm-handle-multipart-original-buffer (handle)
  `(get-text-property 0 'buffer (car ,handle)))
(defmacro mm-handle-multipart-from (handle)
  `(get-text-property 0 'from (car ,handle)))
(defmacro mm-handle-multipart-ctl-parameter (handle parameter)
  `(get-text-property 0 ,parameter (car ,handle)))

Gerd Moellmann's avatar
Gerd Moellmann committed
112 113 114 115 116 117
(defmacro mm-make-handle (&optional buffer type encoding undisplayer
				    disposition description cache
				    id)
  `(list ,buffer ,type ,encoding ,undisplayer
	 ,disposition ,description ,cache ,id))

118
(defcustom mm-text-html-renderer
119 120
  (cond ((fboundp 'libxml-parse-html-region) 'shr)
	((executable-find "w3m") 'gnus-w3m)
121 122
	((executable-find "links") 'links)
	((executable-find "lynx") 'lynx)
Miles Bader's avatar
Miles Bader committed
123 124
	((locate-library "html2text") 'html2text)
	(t nil))
125 126 127
  "Render of HTML contents.
It is one of defined renderer types, or a rendering function.
The defined renderer types are:
128 129 130 131
`shr': use the built-in Gnus HTML renderer;
`gnus-w3m': use Gnus renderer based on w3m;
`w3m': use emacs-w3m;
`w3m-standalone': use plain w3m;
132
`links': use links;
133 134
`lynx': use lynx;
`html2text': use html2text;
Miles Bader's avatar
Miles Bader committed
135
nil    : use external viewer (default web browser)."
136
  :version "24.1"
137 138
  :type '(choice (const shr)
                 (const gnus-w3m)
139
                 (const w3m :tag "emacs-w3m")
Miles Bader's avatar
Miles Bader committed
140
		 (const w3m-standalone :tag "standalone w3m" )
141 142 143
		 (const links)
		 (const lynx)
		 (const html2text)
Miles Bader's avatar
Miles Bader committed
144
		 (const nil :tag "External viewer")
145 146 147
		 (function))
  :group 'mime-display)

148
(defcustom mm-html-inhibit-images nil
149 150
  "Non-nil means inhibit displaying of images inline in the article body."
  :version "25.1"
151 152 153
  :type 'boolean
  :group 'mime-display)

154
(defcustom mm-html-blocked-images nil
155 156 157 158 159 160 161
  "Regexp matching image URLs to be blocked, or nil meaning not to block.
Note that cid images that are embedded in a message won't be blocked."
  :version "25.1"
  :type '(choice (const :tag "Allow all" nil)
		 (regexp :tag "Regular expression"))
  :group 'mime-display)

162 163 164 165 166 167 168 169 170 171 172 173
(defcustom mm-w3m-safe-url-regexp "\\`cid:"
  "Regexp matching URLs which are considered to be safe.
Some HTML mails might contain a nasty trick used by spammers, using
the <img> tag which is far more evil than the [Click Here!] button.
It is most likely intended to check whether the ominous spam mail has
reached your eyes or not, in which case the spammer knows for sure
that your email address is valid.  It is done by embedding an
identifier string into a URL that you might automatically retrieve
when displaying the image.  The default value is \"\\\\`cid:\" which only
matches parts embedded to the Multipart/Related type MIME contents and
Gnus will never connect to the spammer's site arbitrarily.  You may
set this variable to nil if you consider all urls to be safe."
174
  :version "22.1"
175 176 177 178 179 180
  :type '(choice (regexp :tag "Regexp")
		 (const :tag "All URLs are safe" nil))
  :group 'mime-display)

(defcustom mm-inline-text-html-with-w3m-keymap t
  "If non-nil, use emacs-w3m command keys in the article buffer."
181
  :version "22.1"
182 183 184 185 186 187 188 189 190
  :type 'boolean
  :group 'mime-display)

(defcustom mm-enable-external t
  "Indicate whether external MIME handlers should be used.

If t, all defined external MIME handlers are used.  If nil, files are saved by
`mailcap-save-binary-file'.  If it is the symbol `ask', you are prompted
before the external MIME handler is invoked."
191
  :version "22.1"
192 193 194 195 196
  :type '(choice (const :tag "Always" t)
		 (const :tag "Never" nil)
		 (const :tag "Ask" ask))
  :group 'mime-display)

Gerd Moellmann's avatar
Gerd Moellmann committed
197
(defcustom mm-inline-media-tests
198
  '(("image/p?jpeg"
Gerd Moellmann's avatar
Gerd Moellmann committed
199 200 201 202 203 204 205 206 207 208 209 210 211 212
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'jpeg handle)))
    ("image/png"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'png handle)))
    ("image/gif"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'gif handle)))
    ("image/tiff"
     mm-inline-image
     (lambda (handle)
213
       (mm-valid-and-fit-image-p 'tiff handle)))
Gerd Moellmann's avatar
Gerd Moellmann committed
214 215 216 217 218 219 220 221 222 223 224 225
    ("image/xbm"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'xbm handle)))
    ("image/x-xbitmap"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'xbm handle)))
    ("image/xpm"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'xpm handle)))
226
    ("image/x-xpixmap"
Gerd Moellmann's avatar
Gerd Moellmann committed
227 228 229 230 231 232 233
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'xpm handle)))
    ("image/bmp"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'bmp handle)))
Dave Love's avatar
Dave Love committed
234 235 236 237
    ("image/x-portable-bitmap"
     mm-inline-image
     (lambda (handle)
       (mm-valid-and-fit-image-p 'pbm handle)))
Gerd Moellmann's avatar
Gerd Moellmann committed
238 239 240
    ("text/plain" mm-inline-text identity)
    ("text/enriched" mm-inline-text identity)
    ("text/richtext" mm-inline-text identity)
241
    ("text/x-patch" mm-display-patch-inline identity)
242
    ;; In case mime.types uses x-diff (as does Debian's mime-support-3.40).
243
    ("text/x-diff" mm-display-patch-inline identity)
Dave Love's avatar
Dave Love committed
244
    ("application/emacs-lisp" mm-display-elisp-inline identity)
245
    ("application/x-emacs-lisp" mm-display-elisp-inline identity)
246 247 248
    ("application/x-shellscript" mm-display-shell-script-inline identity)
    ("application/x-sh" mm-display-shell-script-inline identity)
    ("text/x-sh" mm-display-shell-script-inline identity)
249
    ("application/javascript" mm-display-javascript-inline identity)
250
    ("text/dns" mm-display-dns-inline identity)
251
    ("text/x-org" mm-display-org-inline identity)
Gerd Moellmann's avatar
Gerd Moellmann committed
252
    ("text/html"
253
     mm-inline-text-html
Gerd Moellmann's avatar
Gerd Moellmann committed
254
     (lambda (handle)
255
       mm-text-html-renderer))
Gerd Moellmann's avatar
Gerd Moellmann committed
256
    ("text/x-vcard"
257
     mm-inline-text-vcard
Gerd Moellmann's avatar
Gerd Moellmann committed
258 259 260 261 262 263
     (lambda (handle)
       (or (featurep 'vcard)
	   (locate-library "vcard"))))
    ("message/delivery-status" mm-inline-text identity)
    ("message/rfc822" mm-inline-message identity)
    ("message/partial" mm-inline-partial identity)
264
    ("message/external-body" mm-inline-external-body identity)
Gerd Moellmann's avatar
Gerd Moellmann committed
265
    ("text/.*" mm-inline-text identity)
266 267
    ("application/x-.?tar\\(-.*\\)?" mm-archive-dissect-and-inline identity)
    ("application/zip" mm-archive-dissect-and-inline identity)
Gerd Moellmann's avatar
Gerd Moellmann committed
268 269 270 271 272 273 274 275 276 277
    ("audio/wav" mm-inline-audio
     (lambda (handle)
       (and (or (featurep 'nas-sound) (featurep 'native-sound))
	    (device-sound-enabled-p))))
    ("audio/au"
     mm-inline-audio
     (lambda (handle)
       (and (or (featurep 'nas-sound) (featurep 'native-sound))
	    (device-sound-enabled-p))))
    ("application/pgp-signature" ignore identity)
278 279 280 281
    ("application/x-pkcs7-signature" ignore identity)
    ("application/pkcs7-signature" ignore identity)
    ("application/x-pkcs7-mime" ignore identity)
    ("application/pkcs7-mime" ignore identity)
Gerd Moellmann's avatar
Gerd Moellmann committed
282 283
    ("multipart/alternative" ignore identity)
    ("multipart/mixed" ignore identity)
284
    ("multipart/related" ignore identity)
285
    ("image/.*"
286 287 288 289 290 291 292 293 294
     mm-inline-image
     (lambda (handle)
       (and (mm-valid-image-format-p 'imagemagick)
	    (mm-with-unibyte-buffer
	      (mm-insert-part handle)
	      (let ((image
		     (ignore-errors
		       (if (fboundp 'create-image)
			   (create-image (buffer-string) 'imagemagick 'data-p)
295 296
			 (mm-create-image-xemacs
			  (mm-handle-media-subtype handle))))))
297 298 299
		(when image
		  (setcar (cdr handle) (list "image/imagemagick"))
		  (mm-image-fit-p handle)))))))
300 301 302 303 304
    ;; Disable audio and image
    ("audio/.*" ignore ignore)
    ("image/.*" ignore ignore)
    ;; Default to displaying as text
    (".*" mm-inline-text mm-readable-p))
Gerd Moellmann's avatar
Gerd Moellmann committed
305
  "Alist of media types/tests saying whether types can be displayed inline."
306
  :type '(repeat (list (regexp :tag "MIME type")
Gerd Moellmann's avatar
Gerd Moellmann committed
307 308 309 310 311 312
		       (function :tag "Display function")
		       (function :tag "Display test")))
  :group 'mime-display)

(defcustom mm-inlined-types
  '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
313 314 315 316
    "message/partial" "message/external-body" "application/emacs-lisp"
    "application/x-emacs-lisp"
    "application/pgp-signature" "application/x-pkcs7-signature"
    "application/pkcs7-signature" "application/x-pkcs7-mime"
317
    "application/pkcs7-mime"
318 319 320
    "application/x-gtar-compressed"
    "application/x-tar"
    "application/zip"
321 322
    ;; Mutt still uses this even though it has already been withdrawn.
    "application/pgp")
323 324 325
  "List of media types that are to be displayed inline.
See also `mm-inline-media-tests', which says how to display a media
type inline."
326
  :type '(repeat regexp)
327 328 329 330 331 332 333
  :group 'mime-display)

(defcustom mm-keep-viewer-alive-types
  '("application/postscript" "application/msword" "application/vnd.ms-excel"
    "application/pdf" "application/x-dvi")
  "List of media types for which the external viewer will not be killed
when selecting a different article."
334
  :version "22.1"
335
  :type '(repeat regexp)
Gerd Moellmann's avatar
Gerd Moellmann committed
336
  :group 'mime-display)
337

Gerd Moellmann's avatar
Gerd Moellmann committed
338
(defcustom mm-automatic-display
339
  '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-verbatim"
Gerd Moellmann's avatar
Gerd Moellmann committed
340
    "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
341
    "message/rfc822" "text/x-patch" "text/dns" "application/pgp-signature"
342 343 344
    "application/emacs-lisp" "application/x-emacs-lisp"
    "application/x-pkcs7-signature"
    "application/pkcs7-signature" "application/x-pkcs7-mime"
345 346
    "application/pkcs7-mime"
    ;; Mutt still uses this even though it has already been withdrawn.
347
    "application/pgp\\'"
348
     "text/x-org")
Gerd Moellmann's avatar
Gerd Moellmann committed
349
  "A list of MIME types to be displayed automatically."
350
  :type '(repeat regexp)
Gerd Moellmann's avatar
Gerd Moellmann committed
351 352
  :group 'mime-display)

353 354 355 356 357
(defcustom mm-attachment-override-types '("text/x-vcard"
					  "application/pkcs7-mime"
					  "application/x-pkcs7-mime"
					  "application/pkcs7-signature"
					  "application/x-pkcs7-signature")
Gerd Moellmann's avatar
Gerd Moellmann committed
358
  "Types to have \"attachment\" ignored if they can be displayed inline."
359
  :type '(repeat regexp)
Gerd Moellmann's avatar
Gerd Moellmann committed
360 361 362 363
  :group 'mime-display)

(defcustom mm-inline-override-types nil
  "Types to be treated as attachments even if they can be displayed inline."
364
  :type '(repeat regexp)
Gerd Moellmann's avatar
Gerd Moellmann committed
365 366 367 368
  :group 'mime-display)

(defcustom mm-automatic-external-display nil
  "List of MIME type regexps that will be displayed externally automatically."
369
  :type '(repeat regexp)
Gerd Moellmann's avatar
Gerd Moellmann committed
370 371 372 373 374 375 376 377 378 379 380
  :group 'mime-display)

(defcustom mm-discouraged-alternatives nil
  "List of MIME types that are discouraged when viewing multipart/alternative.
Viewing agents are supposed to view the last possible part of a message,
as that is supposed to be the richest.  However, users may prefer other
types instead, and this list says what types are most unwanted.  If,
for instance, text/html parts are very unwanted, and text/richtext are
somewhat unwanted, then the value of this variable should be set
to:

381 382 383
 (\"text/html\" \"text/richtext\")

Adding \"image/.*\" might also be useful.  Spammers use it as the
Paul Eggert's avatar
Paul Eggert committed
384
preferred part of multipart/alternative messages.  See also
385 386
`gnus-buttonized-mime-types', to which adding \"multipart/alternative\"
enables you to choose manually one of two types those mails include."
387
  :type '(repeat regexp) ;; See `mm-preferred-alternative-precedence'.
Gerd Moellmann's avatar
Gerd Moellmann committed
388 389
  :group 'mime-display)

390 391 392 393 394 395 396 397 398
(defcustom mm-tmp-directory
  (if (fboundp 'temp-directory)
      (temp-directory)
    (if (boundp 'temporary-file-directory)
	temporary-file-directory
      "/tmp/"))
  "Where mm will store its temporary files."
  :type 'directory
  :group 'mime-display)
Gerd Moellmann's avatar
Gerd Moellmann committed
399 400

(defcustom mm-inline-large-images nil
401
  "If t, then all images fit in the buffer.
402
If `resize', try to resize the images so they fit."
403 404 405 406
  :type '(radio
          (const :tag "Inline large images as they are." t)
          (const :tag "Resize large images." resize)
          (const :tag "Do not inline large images." nil))
Gerd Moellmann's avatar
Gerd Moellmann committed
407 408
  :group 'mime-display)

409
(defcustom mm-file-name-rewrite-functions
410
  '(mm-file-name-delete-control mm-file-name-delete-gotchas)
411
  "List of functions used for rewriting file names of MIME parts.
412 413
Each function takes a file name as input and returns a file name.

414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433
Ready-made functions include `mm-file-name-delete-control',
`mm-file-name-delete-gotchas' (you should not remove these two
functions), `mm-file-name-delete-whitespace',
`mm-file-name-trim-whitespace', `mm-file-name-collapse-whitespace',
`mm-file-name-replace-whitespace', `capitalize', `downcase',
`upcase', and `upcase-initials'."
  :type '(list (set :inline t
		    (const mm-file-name-delete-control)
		    (const mm-file-name-delete-gotchas)
		    (const mm-file-name-delete-whitespace)
		    (const mm-file-name-trim-whitespace)
		    (const mm-file-name-collapse-whitespace)
		    (const mm-file-name-replace-whitespace)
		    (const capitalize)
		    (const downcase)
		    (const upcase)
		    (const upcase-initials)
	       (repeat :inline t
		       :tag "Function"
		       function)))
434
  :version "23.1" ;; No Gnus
435 436
  :group 'mime-display)

437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456

(defvar mm-path-name-rewrite-functions nil
  "*List of functions for rewriting the full file names of MIME parts.
This is used when viewing parts externally, and is meant for
transforming the absolute name so that non-compliant programs can find
the file where it's saved.

Each function takes a file name as input and returns a file name.")

(defvar mm-file-name-replace-whitespace nil
  "String used for replacing whitespace characters; default is `\"_\"'.")

(defcustom mm-default-directory nil
  "The default directory where mm will save files.
If not set, `default-directory' will be used."
  :type '(choice directory (const :tag "Default" nil))
  :group 'mime-display)

(defcustom mm-attachment-file-modes 384
  "Set the mode bits of saved attachments to this integer."
457
  :version "22.1"
458 459 460 461 462
  :type 'integer
  :group 'mime-display)

(defcustom mm-external-terminal-program "xterm"
  "The program to start an external terminal."
463
  :version "22.1"
464 465 466
  :type 'string
  :group 'mime-display)

Gerd Moellmann's avatar
Gerd Moellmann committed
467 468 469 470
;;; Internal variables.

(defvar mm-last-shell-command "")
(defvar mm-content-id-alist nil)
471
(defvar mm-postponed-undisplay-list nil)
472
(defvar mm-inhibit-auto-detect-attachment nil)
473 474 475 476 477
(defvar mm-temp-files-to-be-deleted nil
  "List of temporary files scheduled to be deleted.")
(defvar mm-temp-files-cache-file (concat ".mm-temp-files-" (user-login-name))
  "Name of a file that caches a list of temporary files to be deleted.
The file will be saved in the directory `mm-tmp-directory'.")
Gerd Moellmann's avatar
Gerd Moellmann committed
478 479 480 481 482 483

;; According to RFC2046, in particular, in a digest, the default
;; Content-Type value for a body part is changed from "text/plain" to
;; "message/rfc822".
(defvar mm-dissect-default-type "text/plain")

484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500
(autoload 'mml2015-verify "mml2015")
(autoload 'mml2015-verify-test "mml2015")
(autoload 'mml-smime-verify "mml-smime")
(autoload 'mml-smime-verify-test "mml-smime")

(defvar mm-verify-function-alist
  '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test)
    ("application/x-gnus-pgp-signature" mm-uu-pgp-signed-extract-1 "PGP"
     mm-uu-pgp-signed-test)
    ("application/pkcs7-signature" mml-smime-verify "S/MIME"
     mml-smime-verify-test)
    ("application/x-pkcs7-signature" mml-smime-verify "S/MIME"
     mml-smime-verify-test)))

(defcustom mm-verify-option 'never
  "Option of verifying signed parts.
`never', not verify; `always', always verify;
501 502 503 504 505
`known', only verify known protocols.  Otherwise, ask user.

When set to `always' or `known', you should add
\"multipart/signed\" to `gnus-buttonized-mime-types' to see
result of the verification."
506
  :version "22.1"
507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524
  :type '(choice (item always)
		 (item never)
		 (item :tag "only known protocols" known)
		 (item :tag "ask" nil))
  :group 'mime-security)

(autoload 'mml2015-decrypt "mml2015")
(autoload 'mml2015-decrypt-test "mml2015")

(defvar mm-decrypt-function-alist
  '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test)
    ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP"
     mm-uu-pgp-encrypted-test)))

(defcustom mm-decrypt-option nil
  "Option of decrypting encrypted parts.
`never', not decrypt; `always', always decrypt;
`known', only decrypt known protocols.  Otherwise, ask user."
525
  :version "22.1"
526 527 528 529 530 531 532 533 534
  :type '(choice (item always)
		 (item never)
		 (item :tag "only known protocols" known)
		 (item :tag "ask" nil))
  :group 'mime-security)

(defvar mm-viewer-completion-map
  (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
    (set-keymap-parent map minibuffer-local-completion-map)
535 536
    ;; Should we bind other key to minibuffer-complete-word?
    (define-key map " " 'self-insert-command)
537 538 539
    map)
  "Keymap for input viewer with completion.")

Gerd Moellmann's avatar
Gerd Moellmann committed
540 541
;;; The functions.

542 543 544 545 546 547 548 549 550 551
(defun mm-alist-to-plist (alist)
  "Convert association list ALIST into the equivalent property-list form.
The plist is returned.  This converts from

\((a . 1) (b . 2) (c . 3))

into

\(a 1 b 2 c 3)

552
The original alist is not modified."
553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585
  (let (plist)
    (while alist
      (let ((el (car alist)))
	(setq plist (cons (cdr el) (cons (car el) plist))))
      (setq alist (cdr alist)))
    (nreverse plist)))

(defun mm-keep-viewer-alive-p (handle)
  "Say whether external viewer for HANDLE should stay alive."
  (let ((types mm-keep-viewer-alive-types)
	(type (mm-handle-media-type handle))
	ty)
    (catch 'found
      (while (setq ty (pop types))
	(when (string-match ty type)
	  (throw 'found t))))))

(defun mm-handle-set-external-undisplayer (handle function)
  "Set the undisplayer for HANDLE to FUNCTION.
Postpone undisplaying of viewers for types in
`mm-keep-viewer-alive-types'."
  (if (mm-keep-viewer-alive-p handle)
      (let ((new-handle (copy-sequence handle)))
	(mm-handle-set-undisplayer new-handle function)
	(mm-handle-set-undisplayer handle nil)
	(push new-handle mm-postponed-undisplay-list))
    (mm-handle-set-undisplayer handle function)))

(defun mm-destroy-postponed-undisplay-list ()
  (when mm-postponed-undisplay-list
    (message "Destroying external MIME viewers")
    (mm-destroy-parts mm-postponed-undisplay-list)))

586 587 588 589 590 591 592 593 594 595 596 597 598 599 600
(defun mm-temp-files-delete ()
  "Delete temporary files and those parent directories.
Note that the deletion may fail if a program is catching hold of a file
under Windows or Cygwin.  In that case, it schedules the deletion of
files left at the next time."
  (let* ((coding-system-for-read mm-universal-coding-system)
	 (coding-system-for-write mm-universal-coding-system)
	 (cache-file (expand-file-name mm-temp-files-cache-file
				       mm-tmp-directory))
	 (cache (when (file-exists-p cache-file)
		  (mm-with-multibyte-buffer
		    (insert-file-contents cache-file)
		    (split-string (buffer-string) "\n" t))))
	 fails)
    (dolist (temp (append cache mm-temp-files-to-be-deleted))
601 602 603 604 605 606 607 608 609
      (when (and (file-exists-p temp)
		 (if (file-directory-p temp)
		     ;; A parent directory left at the previous time.
		     (progn
		       (ignore-errors (delete-directory temp))
		       (file-exists-p temp))
		   ;; Delete a temporary file and its parent directory.
		   (ignore-errors (delete-file temp))
		   (or (file-exists-p temp)
610
		       (progn
611
			 (setq temp (file-name-directory temp))
612
			 (ignore-errors (delete-directory temp))
613
			 (file-exists-p temp)))))
614 615 616 617 618 619 620 621 622
	(push temp fails)))
    (if fails
	;; Schedule the deletion of the files left at the next time.
	(progn
	  (write-region (concat (mapconcat 'identity (nreverse fails) "\n")
				"\n")
			nil cache-file nil 'silent)
	  (set-file-modes cache-file #o600))
      (when (file-exists-p cache-file)
623 624
	(ignore-errors (delete-file cache-file))))
    (setq mm-temp-files-to-be-deleted nil)))
625

626 627
(autoload 'message-fetch-field "message")

628
(defun mm-dissect-buffer (&optional no-strict-mime loose-mime from)
629 630 631
  "Dissect the current buffer and return a list of MIME handles.
If NO-STRICT-MIME, don't require the message to have a
MIME-Version header before proceeding."
Gerd Moellmann's avatar
Gerd Moellmann committed
632
  (save-excursion
633
    (let (ct ctl type subtype cte cd description id result)
Gerd Moellmann's avatar
Gerd Moellmann committed
634 635 636
      (save-restriction
	(mail-narrow-to-head)
	(when (or no-strict-mime
637
		  loose-mime
Gerd Moellmann's avatar
Gerd Moellmann committed
638 639
		  (mail-fetch-field "mime-version"))
	  (setq ct (mail-fetch-field "content-type")
640
		ctl (and ct (mail-header-parse-content-type ct))
Gerd Moellmann's avatar
Gerd Moellmann committed
641
		cte (mail-fetch-field "content-transfer-encoding")
642 643 644 645 646 647 648
                cd (or (mail-fetch-field "content-disposition")
                       (when (and ctl
                                  (eq 'mm-inline-text
                                      (cadr (mm-assoc-string-match
                                             mm-inline-media-tests
                                             (car ctl)))))
                         "inline"))
649 650 651
		;; Newlines in description should be stripped so as
		;; not to break the MIME tag into two or more lines.
		description (message-fetch-field "content-description")
652
		id (mail-fetch-field "content-id"))
653
	  (unless from
654
	    (setq from (mail-fetch-field "from")))
655
	  ;; FIXME: In some circumstances, this code is running within
656
	  ;; a unibyte macro.  mail-extract-address-components
657 658 659
	  ;; creates unibyte buffers. This `if', though not a perfect
	  ;; solution, avoids most of them.
	  (if from
Miles Bader's avatar
Miles Bader committed
660 661 662 663
	      (setq from (cadr (mail-extract-address-components from))))
	  (if description
	      (setq description (mail-decode-encoded-word-string
				 description)))))
Gerd Moellmann's avatar
Gerd Moellmann committed
664 665
      (if (or (not ctl)
	      (not (string-match "/" (car ctl))))
666
	    (mm-dissect-singlepart
667
	   (list mm-dissect-default-type)
668
	     (and cte (intern (downcase (mail-header-strip cte))))
669 670 671
	   no-strict-mime
	   (and cd (mail-header-parse-content-disposition cd))
	   description)
Gerd Moellmann's avatar
Gerd Moellmann committed
672 673
	(setq type (split-string (car ctl) "/"))
	(setq subtype (cadr type)
674
	      type (car type))
Gerd Moellmann's avatar
Gerd Moellmann committed
675 676 677 678 679 680
	(setq
	 result
	 (cond
	  ((equal type "multipart")
	   (let ((mm-dissect-default-type (if (equal subtype "digest")
					      "message/rfc822"
681 682 683 684 685 686 687 688
					    "text/plain"))
		 (start (cdr (assq 'start (cdr ctl)))))
	     (add-text-properties 0 (length (car ctl))
				  (mm-alist-to-plist (cdr ctl)) (car ctl))

	     ;; what really needs to be done here is a way to link a
	     ;; MIME handle back to it's parent MIME handle (in a multilevel
	     ;; MIME article).  That would probably require changing
689
	     ;; the mm-handle API so we simply store the multipart buffer
690 691 692 693 694 695
	     ;; name as a text property of the "multipart/whatever" string.
	     (add-text-properties 0 (length (car ctl))
				  (list 'buffer (mm-copy-to-buffer)
					'from from
					'start start)
				  (car ctl))
696
	     (cons (car ctl) (mm-dissect-multipart ctl from))))
Gerd Moellmann's avatar
Gerd Moellmann committed
697
	  (t
698 699 700
	   (mm-possibly-verify-or-decrypt
	    (mm-dissect-singlepart
	     ctl
701
	     (and cte (intern (downcase (mail-header-strip cte))))
702
	     no-strict-mime
703
	     (and cd (mail-header-parse-content-disposition cd))
704
	     description id)
705
	    ctl from))))
Gerd Moellmann's avatar
Gerd Moellmann committed
706 707 708 709 710 711 712 713 714 715 716
	(when id
	  (when (string-match " *<\\(.*\\)> *" id)
	    (setq id (match-string 1 id)))
	  (push (cons id result) mm-content-id-alist))
	result))))

(defun mm-dissect-singlepart (ctl cte &optional force cdl description id)
  (when (or force
	    (if (equal "text/plain" (car ctl))
		(assoc 'format ctl)
	      t))
717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736
    ;; Guess what the type of application/octet-stream parts should
    ;; really be.
    (let ((filename (cdr (assq 'filename (cdr cdl)))))
      (when (and (not mm-inhibit-auto-detect-attachment)
		 (equal (car ctl) "application/octet-stream")
		 filename
		 (string-match "\\.\\([^.]+\\)$" filename))
	(let ((new-type (mailcap-extension-to-mime (match-string 1 filename))))
	  (when new-type
	    (setcar ctl new-type)))))
    (let ((handle
	   (mm-make-handle
	    (mm-copy-to-buffer) ctl cte nil cdl description nil id))
	  (decoder (assoc (car ctl) (mm-archive-decoders))))
      (if (and decoder
	       ;; Do automatic decoding
	       (cadr decoder)
	       (executable-find (caddr decoder)))
	  (mm-dissect-archive handle)
	handle))))
Gerd Moellmann's avatar
Gerd Moellmann committed
737

738
(defun mm-dissect-multipart (ctl from)
Gerd Moellmann's avatar
Gerd Moellmann committed
739 740 741 742 743 744 745 746
  (goto-char (point-min))
  (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
	 (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
	 start parts
	 (end (save-excursion
		(goto-char (point-max))
		(if (re-search-backward close-delimiter nil t)
		    (match-beginning 0)
747 748 749
		  (point-max))))
	 (mm-inhibit-auto-detect-attachment
	  (equal (car ctl) "multipart/encrypted")))
Gerd Moellmann's avatar
Gerd Moellmann committed
750
    (setq boundary (concat (regexp-quote boundary) "[ \t]*$"))
751
    (while (and (< (point) end) (re-search-forward boundary end t))
Gerd Moellmann's avatar
Gerd Moellmann committed
752 753 754 755 756
      (goto-char (match-beginning 0))
      (when start
	(save-excursion
	  (save-restriction
	    (narrow-to-region start (point))
757
	    (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
758 759 760
      (end-of-line 2)
      (or (looking-at boundary)
	  (forward-line 1))
Gerd Moellmann's avatar
Gerd Moellmann committed
761
      (setq start (point)))
762
    (when (and start (< start end))
Gerd Moellmann's avatar
Gerd Moellmann committed
763 764 765
      (save-excursion
	(save-restriction
	  (narrow-to-region start end)
766
	  (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
767
    (mm-possibly-verify-or-decrypt (nreverse parts) ctl from)))
Gerd Moellmann's avatar
Gerd Moellmann committed
768 769 770

(defun mm-copy-to-buffer ()
  "Copy the contents of the current buffer to a fresh buffer."
771
  (let ((obuf (current-buffer))
772
        (mb (mm-multibyte-p))
773 774 775 776
        beg)
    (goto-char (point-min))
    (search-forward-regexp "^\n" nil t)
    (setq beg (point))
777
    (with-current-buffer
778 779 780
          (generate-new-buffer " *mm*")
      ;; Preserve the data's unibyteness (for url-insert-file-contents).
      (mm-set-buffer-multibyte mb)
Gerd Moellmann's avatar
Gerd Moellmann committed
781 782 783
      (insert-buffer-substring obuf beg)
      (current-buffer))))

784 785 786 787 788 789 790 791 792 793
(defun mm-display-parts (handle &optional no-default)
  (if (stringp (car handle))
      (mapcar 'mm-display-parts (cdr handle))
    (if (bufferp (car handle))
	(save-restriction
	  (narrow-to-region (point) (point))
	  (mm-display-part handle)
	  (goto-char (point-max)))
      (mapcar 'mm-display-parts handle))))

794 795 796
(autoload 'mailcap-parse-mailcaps "mailcap")
(autoload 'mailcap-mime-info "mailcap")

797 798 799 800 801 802 803 804
(defun mm-head-p (&optional point)
  "Return non-nil if point is in the article header."
  (let ((point (or point (point))))
    (save-excursion
      (goto-char point)
      (and (not (re-search-backward "^$" nil t))
	   (re-search-forward "^$" nil t)))))

805
(defun mm-display-part (handle &optional no-default force)
Gerd Moellmann's avatar
Gerd Moellmann committed
806 807 808 809 810
  "Display the MIME part represented by HANDLE.
Returns nil if the part is removed; inline if displayed inline;
external if displayed external."
  (save-excursion
    (mailcap-parse-mailcaps)
811 812
    (if (and (not force)
	     (mm-handle-displayed-p handle))
Gerd Moellmann's avatar
Gerd Moellmann committed
813
	(mm-remove-part handle)
814 815 816 817 818 819 820 821
      (let* ((ehandle (if (equal (mm-handle-media-type handle)
				 "message/external-body")
			  (progn
			    (unless (mm-handle-cache handle)
			      (mm-extern-cache-contents handle))
			    (mm-handle-cache handle))
			handle))
	     (type (mm-handle-media-type ehandle))
822 823 824 825 826 827
	     (method (mailcap-mime-info type))
	     (filename (or (mail-content-type-get
			    (mm-handle-disposition handle) 'filename)
			   (mail-content-type-get
			    (mm-handle-type handle) 'name)
			   "<file>"))
828 829 830 831 832 833 834 835 836 837
	     (external mm-enable-external)
	     (decoder (assoc (car (mm-handle-type handle))
			     (mm-archive-decoders))))
	(cond
	 ((and decoder
	       (executable-find (caddr decoder)))
	  (mm-archive-dissect-and-inline handle)
	  'inline)
	 ((and (mm-inlinable-p ehandle)
	       (mm-inlined-p ehandle))
838 839 840 841
	  (when force
	    (if (mm-head-p)
		(re-search-forward "^$" nil t)
	      (forward-line 1)))
842 843 844 845 846 847 848 849 850 851 852 853
	  (mm-display-inline handle)
	  'inline)
	 ((or method
	      (not no-default))
	  (if (and (not method)
		   (equal "text" (car (split-string type "/"))))
	      (progn
		(forward-line 1)
		(mm-insert-inline handle (mm-get-part handle))
		'inline)
	    (setq external
		  (and method	      ;; If nil, we always use "save".
854 855 856 857 858
		       (or (eq mm-enable-external t)
			   (and (eq mm-enable-external 'ask)
				(y-or-n-p
				 (concat
				  "Display part (" type
859
				  ") "
860 861
				  (if (stringp method)
				      (concat
862 863
				       "using external program \""
				       (format method filename) "\"")
Paul Eggert's avatar
Paul Eggert committed
864
				    (gnus-format-message
865
				     "by calling `%s' on the contents)" method))
866 867
				  "? "))))))
	    (if external
868
		(mm-display-external
869 870 871
		 handle (or method 'mailcap-save-binary-file))
	      (mm-display-external
	       handle 'mailcap-save-binary-file)))))))))
Gerd Moellmann's avatar
Gerd Moellmann committed
872

873
(declare-function gnus-configure-windows "gnus-win" (setting &optional force))
874
(defvar mailcap-mime-extensions)	; mailcap-mime-info autoloads
875 876
(declare-function term-mode "term" ())
(declare-function term-char-mode "term" ())
877

Gerd Moellmann's avatar
Gerd Moellmann committed
878 879 880 881 882 883 884 885
(defun mm-display-external (handle method)
  "Display HANDLE using METHOD."
  (let ((outbuf (current-buffer)))
    (mm-with-unibyte-buffer
      (if (functionp method)
	  (let ((cur (current-buffer)))
	    (if (eq method 'mailcap-save-binary-file)
		(progn
886
		  (set-buffer (generate-new-buffer " *mm*"))
Gerd Moellmann's avatar
Gerd Moellmann committed
887 888
		  (setq method nil))
	      (mm-insert-part handle)
Miles Bader's avatar
Miles Bader committed
889
	      (mm-add-meta-html-tag handle)
Gerd Moellmann's avatar
Gerd Moellmann committed
890 891 892
	      (let ((win (get-buffer-window cur t)))
		(when win
		  (select-window win)))
893
	      (switch-to-buffer (generate-new-buffer " *mm*")))
894
	    (buffer-disable-undo)
Gerd Moellmann's avatar
Gerd Moellmann committed
895 896 897
	    (mm-set-buffer-file-coding-system mm-binary-coding-system)
	    (insert-buffer-substring cur)
	    (goto-char (point-min))
898 899
	    (when method
	      (message "Viewing with %s" method))
Gerd Moellmann's avatar
Gerd Moellmann committed
900 901 902 903 904 905
	    (let ((mm (current-buffer))
		  (non-viewer (assq 'non-viewer
				    (mailcap-mime-info
				     (mm-handle-media-type handle) t))))
	      (unwind-protect
		  (if method
906 907 908 909
		      (progn
			(when (and (boundp 'gnus-summary-buffer)
				   (bufferp gnus-summary-buffer)
				   (buffer-name gnus-summary-buffer))
Paul Eggert's avatar
Paul Eggert committed
910
			  ;; So that we pop back to the right place, sort of.
911 912 913 914
			  (switch-to-buffer gnus-summary-buffer)
			  (switch-to-buffer mm))
			(delete-other-windows)
			(funcall method))
Gerd Moellmann's avatar
Gerd Moellmann committed
915 916 917 918 919 920
		    (mm-save-part handle))
		(when (and (not non-viewer)
			   method)
		  (mm-handle-set-undisplayer handle mm)))))
	;; The function is a string to be executed.
	(mm-insert-part handle)
Miles Bader's avatar
Miles Bader committed
921
	(mm-add-meta-html-tag handle)
922
	(let* ((dir (mm-make-temp-file
923
		     (expand-file-name "emm." mm-tmp-directory) 'dir))
924 925 926 927 928
	       (filename (or
			  (mail-content-type-get
			   (mm-handle-disposition handle) 'filename)
			  (mail-content-type-get
			   (mm-handle-type handle) 'name)))
Gerd Moellmann's avatar
Gerd Moellmann committed
929 930 931 932 933 934 935
	       (mime-info (mailcap-mime-info
			   (mm-handle-media-type handle) t))
	       (needsterm (or (assoc "needsterm" mime-info)
			      (assoc "needsterminal" mime-info)))
	       (copiousoutput (assoc "copiousoutput" mime-info))
	       file buffer)
	  ;; We create a private sub-directory where we store our files.
Miles Bader's avatar
Miles Bader committed
936
	  (set-file-modes dir #o700)
Gerd Moellmann's avatar
Gerd Moellmann committed
937
	  (if filename
938 939 940 941
	      (setq file (expand-file-name
			  (gnus-map-function mm-file-name-rewrite-functions
					     (file-name-nondirectory filename))
			  dir))
942 943 944 945 946 947 948 949 950 951 952 953
	    ;; Use nametemplate (defined in RFC1524) if it is specified
	    ;; in mailcap.
	    (let ((suffix (cdr (assoc "nametemplate" mime-info))))
	      (if (and suffix
		       (string-match "\\`%s\\(\\..+\\)\\'" suffix))
		  (setq suffix (match-string 1 suffix))
		;; Otherwise, use a suffix according to
		;; `mailcap-mime-extensions'.
		(setq suffix (car (rassoc (mm-handle-media-type handle)
					  mailcap-mime-extensions))))
	      (setq file (mm-make-temp-file (expand-file-name "mm." dir)
					    nil suffix))))
Gerd Moellmann's avatar
Gerd Moellmann committed
954 955
	  (let ((coding-system-for-write mm-binary-coding-system))
	    (write-region (point-min) (point-max) file nil 'nomesg))
Miles Bader's avatar
Miles Bader committed
956 957 958 959
	  ;; The file is deleted after the viewer exists.  If the users edits
	  ;; the file, changes will be lost.  Set file to read-only to make it
	  ;; clear.
	  (set-file-modes file #o400)
Gerd Moellmann's avatar
Gerd Moellmann committed
960
	  (message "Viewing with %s" method)
961 962 963 964 965 966
	  (cond
	   (needsterm
	    (let ((command (mm-mailcap-command
			    method file (mm-handle-type handle))))
	      (unwind-protect
		  (if window-system
967 968 969 970 971 972 973 974 975 976 977 978 979 980
		      (set-process-sentinel
		       (start-process "*display*" nil
				      mm-external-terminal-program
				      "-e" shell-file-name
				      shell-command-switch command)
		       `(lambda (process state)
			  (if (eq 'exit (process-status process))
			      (run-at-time
			       60.0 nil
			       (lambda ()
				 (ignore-errors (delete-file ,file))
				 (ignore-errors (delete-directory
						 ,(file-name-directory
						   file))))))))
981 982 983 984 985 986 987 988 989 990 991 992 993
		    (require 'term)
		    (require 'gnus-win)
		    (set-buffer
		     (setq buffer
			   (make-term "display"
				      shell-file-name
				      nil
				      shell-command-switch command)))
		    (term-mode)
		    (term-char-mode)
		    (set-process-sentinel
		     (get-buffer-process buffer)
		     `(lambda (process state)
994 995 996 997 998 999
			(when (eq 'exit (process-status process))
			  (ignore-errors (delete-file ,file))
			  (ignore-errors
			    (delete-directory ,(file-name-directory file)))
			  (gnus-configure-windows
			   ',gnus-current-window-configuration))))
1000
		    (gnus-configure-windows 'display-term))
1001 1002
		(mm-handle-set-external-undisplayer handle (cons file buffer))
		(add-to-list 'mm-temp-files-to-be-deleted file t))
1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019
	      (message "Displaying %s..." command))
	    'external)
	   (copiousoutput
	    (with-current-buffer outbuf
	      (forward-line 1)
	      (mm-insert-inline
	       handle
	       (unwind-protect
		   (progn
		     (call-process shell-file-name nil
				   (setq buffer
					 (generate-new-buffer " *mm*"))
				   nil
				   shell-command-switch
				   (mm-mailcap-command
				    method file (mm-handle-type handle)))
		     (if (buffer-live-p buffer)
1020
			 (with-current-buffer buffer
1021 1022 1023 1024 1025 1026 1027 1028
			   (buffer-string))))
		 (progn
		   (ignore-errors (delete-file file))
		   (ignore-errors (delete-directory
				   (file-name-directory file)))
		   (ignore-errors (kill-buffer buffer))))))
	    'inline)
	   (t
1029 1030 1031
	    ;; Deleting the temp file should be postponed for some wrappers,
	    ;; shell scripts, and so on, which might exit right after having
	    ;; started a viewer command as a background job.
1032 1033 1034
	    (let ((command (mm-mailcap-command
			    method file (mm-handle-type handle))))
	      (unwind-protect
1035
		  (let ((process-connection-type nil))
1036 1037 1038 1039 1040 1041 1042
		    (start-process "*display*"
				   (setq buffer
					 (generate-new-buffer " *mm*"))
				   shell-file-name
				   shell-command-switch command)
		    (set-process-sentinel
		     (get-buffer-process buffer)
1043 1044 1045 1046 1047 1048 1049
		     (lexical-let ((outbuf outbuf)
				   (file file)
				   (buffer buffer)
				   (command command)
				   (handle handle))
		       (lambda (process state)
			 (when (eq (process-status process) 'exit)
1050 1051 1052 1053 1054 1055
			   (run-at-time
			    60.0 nil
			    (lambda ()
			      (ignore-errors (delete-file file))
			      (ignore-errors (delete-directory
					      (file-name-directory file)))))
1056 1057 1058 1059 1060
			   (when (buffer-live-p outbuf)
			     (with-current-buffer outbuf
			       (let ((buffer-read-only nil)
				     (point (point)))
				 (forward-line 2)
1061 1062 1063 1064 1065 1066
				 (let ((start (point)))
				   (mm-insert-inline
				    handle (with-current-buffer buffer
					     (buffer-string)))
				   (put-text-property start (point)
						      'face 'mm-command-output))
1067 1068 1069 1070
				 (goto-char point))))
			   (when (buffer-live-p buffer)
			     (kill-buffer buffer)))
			 (message "Displaying %s...done" command)))))
1071
		(mm-handle-set-external-undisplayer
1072 1073
		 handle (cons file buffer))
		(add-to-list 'mm-temp-files-to-be-deleted file t))
1074 1075
	      (message "Displaying %s..." command))
	    'external)))))))
1076

Gerd Moellmann's avatar
Gerd Moellmann committed
1077 1078 1079 1080 1081
(defun mm-mailcap-command (method file type-list)
  (let ((ctl (cdr type-list))
	(beg 0)
	(uses-stdin t)
	out sub total)
1082 1083
    (while (string-match "%{\\([^}]+\\)}\\|'%s'\\|\"%s\"\\|%s\\|%t\\|%%"
			 method beg)
Gerd Moellmann's avatar
Gerd Moellmann committed
1084 1085 1086 1087 1088 1089 1090
      (push (substring method beg (match-beginning 0)) out)
      (setq beg (match-end 0)
	    total (match-string 0 method)
	    sub (match-string 1 method))
      (cond
       ((string= total "%%")
	(push "%" out))
1091 1092 1093 1094
       ((or (string= total "%s")
	    ;; We do our own quoting.
	    (string= total "'%s'")
	    (string= total "\"%s\""))
Gerd Moellmann's avatar
Gerd Moellmann committed
1095
	(setq uses-stdin nil)
1096
	(push (shell-quote-argument
1097
	       (gnus-map-function mm-path-name-rewrite-functions file)) out))
Gerd Moellmann's avatar
Gerd Moellmann committed
1098
       ((string= total "%t")
1099
	(push (shell-quote-argument (car type-list)) out))
Gerd Moellmann's avatar
Gerd Moellmann committed
1100
       (t
1101
	(push (shell-quote-argument (or (cdr (assq (intern sub) ctl)) "")) out))))
Gerd Moellmann's avatar
Gerd Moellmann committed
1102
    (push (substring method beg (length method)) out)
1103 1104
    (when uses-stdin
      (push "<" out)
1105
      (push (shell-quote-argument
1106 1107
	     (gnus-map-function mm-path-name-rewrite-functions file))
	    out))
Gerd Moellmann's avatar
Gerd Moellmann committed
1108
    (mapconcat 'identity (nreverse out) "")))
1109

Gerd Moellmann's avatar
Gerd Moellmann committed
1110 1111 1112 1113 1114 1115 1116 1117 1118
(defun mm-remove-parts (handles)
  "Remove the displayed MIME parts represented by HANDLES."
  (if (and (listp handles)
	   (bufferp (car handles)))
      (mm-remove-part handles)
    (let (handle)
      (while (setq handle (pop handles))
	(cond
	 ((stringp handle)
1119 1120
	  (when (buffer-live-p (get-text-property 0 'buffer handle))
	    (kill-buffer (get-text-property 0 'buffer handle))))
Gerd Moellmann's avatar
Gerd Moellmann committed
1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135
	 ((and (listp handle)
	       (stringp (car handle)))
	  (mm-remove-parts (cdr handle)))
	 (t
	  (mm-remove-part handle)))))))

(defun mm-destroy-parts (handles)
  "Remove the displayed MIME parts represented by HANDLES."
  (if (and (listp handles)
	   (bufferp (car handles)))
      (mm-destroy-part handles)
    (let (handle)
      (while (setq handle (pop handles))
	(cond
	 ((stringp handle)
1136 1137
	  (when (buffer-live-p (get-text-property 0 'buffer handle))
	    (kill-buffer (get-text-property 0 'buffer handle))))
Gerd Moellmann's avatar
Gerd Moellmann committed
1138 1139
	 ((and (listp handle)
	       (stringp (car handle)))
1140
	  (mm-destroy-parts handle))
Gerd Moellmann's avatar
Gerd Moellmann committed
1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151
	 (t
	  (mm-destroy-part handle)))))))

(defun mm-remove-part (handle)
  "Remove the displayed MIME part represented by HANDLE."
  (when (listp handle)
    (let ((object (mm-handle-undisplayer handle)))
      (ignore-errors
	(cond
	 ;; Internally displayed part.
	 ((mm-annotationp object)
1152 1153
          (if (featurep 'xemacs)
              (delete-annotation object)))
Gerd Moellmann's avatar
Gerd Moellmann committed
1154 1155 1156 1157 1158 1159
	 ((or (functionp object)
	      (and (listp object)
		   (eq (car object) 'lambda)))
	  (funcall object))
	 ;; Externally displayed part.
	 ((consp object)
1160 1161 1162 1163 1164 1165 1166 1167 1168
	  (condition-case ()
	      (while (get-buffer-process (cdr object))
		(interrupt-process (get-buffer-process (cdr object)))
		(message "Waiting for external displayer to die...")
		(sit-for 1))
	    (quit)
	    (error))
	  (ignore-errors (and (cdr object) (kill-buffer (cdr object))))
	  (message "Waiting for external displayer to die...done")
Gerd Moellmann's avatar
Gerd Moellmann committed
1169
	  (ignore-errors (delete-file (car object)))
1170 1171
	  (ignore-errors (delete-directory (file-name-directory
					    (car object)))))
Gerd Moellmann's avatar
Gerd Moellmann committed
1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187
	 ((bufferp object)
	  (when (buffer-live-p object)
	    (kill-buffer object)))))
      (mm-handle-set-undisplayer handle nil))))

(defun mm-display-inline (handle)
  (let* ((type (mm-handle-media-type handle))
	 (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
    (funcall function handle)
    (goto-char (point-min))))

(defun mm-assoc-string-match (alist type)
  (dolist (elem alist)
    (when (string-match (car elem) type)
      (return elem))))