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