1 |
;;; mm-decode.el --- functions for decoding MIME things |
;;; mm-decode.el --- Functions for decoding MIME things |
2 |
;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. |
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004 |
3 |
|
;; Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
6 |
;; MORIOKA Tomohiko <morioka@jaist.ac.jp> |
;; MORIOKA Tomohiko <morioka@jaist.ac.jp> |
28 |
(require 'mail-parse) |
(require 'mail-parse) |
29 |
(require 'mailcap) |
(require 'mailcap) |
30 |
(require 'mm-bodies) |
(require 'mm-bodies) |
31 |
(eval-when-compile (require 'cl)) |
(eval-when-compile (require 'cl) |
32 |
|
(require 'term)) |
33 |
|
|
34 |
(eval-and-compile |
(eval-and-compile |
35 |
|
(autoload 'executable-find "executable") |
36 |
(autoload 'mm-inline-partial "mm-partial") |
(autoload 'mm-inline-partial "mm-partial") |
37 |
|
(autoload 'mm-inline-external-body "mm-extern") |
38 |
(autoload 'mm-insert-inline "mm-view")) |
(autoload 'mm-insert-inline "mm-view")) |
39 |
|
|
40 |
|
(add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list) |
41 |
|
|
42 |
(defgroup mime-display () |
(defgroup mime-display () |
43 |
"Display of MIME in mail and news articles." |
"Display of MIME in mail and news articles." |
44 |
:link '(custom-manual "(emacs-mime)Customization") |
:link '(custom-manual "(emacs-mime)Display Customization") |
45 |
:version "21.1" |
:version "21.1" |
46 |
:group 'mail |
:group 'mail |
47 |
:group 'news |
:group 'news |
48 |
:group 'multimedia) |
:group 'multimedia) |
49 |
|
|
50 |
|
(defgroup mime-security () |
51 |
|
"MIME security in mail and news articles." |
52 |
|
:link '(custom-manual "(emacs-mime)Display Customization") |
53 |
|
:group 'mail |
54 |
|
:group 'news |
55 |
|
:group 'multimedia) |
56 |
|
|
57 |
;;; Convenience macros. |
;;; Convenience macros. |
58 |
|
|
59 |
(defmacro mm-handle-buffer (handle) |
(defmacro mm-handle-buffer (handle) |
84 |
`(setcar (nthcdr 6 ,handle) ,contents)) |
`(setcar (nthcdr 6 ,handle) ,contents)) |
85 |
(defmacro mm-handle-id (handle) |
(defmacro mm-handle-id (handle) |
86 |
`(nth 7 ,handle)) |
`(nth 7 ,handle)) |
87 |
|
(defmacro mm-handle-multipart-original-buffer (handle) |
88 |
|
`(get-text-property 0 'buffer (car ,handle))) |
89 |
|
(defmacro mm-handle-multipart-from (handle) |
90 |
|
`(get-text-property 0 'from (car ,handle))) |
91 |
|
(defmacro mm-handle-multipart-ctl-parameter (handle parameter) |
92 |
|
`(get-text-property 0 ,parameter (car ,handle))) |
93 |
|
|
94 |
(defmacro mm-make-handle (&optional buffer type encoding undisplayer |
(defmacro mm-make-handle (&optional buffer type encoding undisplayer |
95 |
disposition description cache |
disposition description cache |
96 |
id) |
id) |
97 |
`(list ,buffer ,type ,encoding ,undisplayer |
`(list ,buffer ,type ,encoding ,undisplayer |
98 |
,disposition ,description ,cache ,id)) |
,disposition ,description ,cache ,id)) |
99 |
|
|
100 |
|
(defcustom mm-text-html-renderer |
101 |
|
(cond ((locate-library "w3") 'w3) |
102 |
|
((executable-find "w3m") (if (locate-library "w3m") |
103 |
|
'w3m |
104 |
|
'w3m-standalone)) |
105 |
|
((executable-find "links") 'links) |
106 |
|
((executable-find "lynx") 'lynx) |
107 |
|
(t 'html2text)) |
108 |
|
"Render of HTML contents. |
109 |
|
It is one of defined renderer types, or a rendering function. |
110 |
|
The defined renderer types are: |
111 |
|
`w3' : use Emacs/W3; |
112 |
|
`w3m' : use emacs-w3m; |
113 |
|
`w3m-standalone': use w3m; |
114 |
|
`links': use links; |
115 |
|
`lynx' : use lynx; |
116 |
|
`html2text' : use html2text; |
117 |
|
nil : use external viewer." |
118 |
|
:type '(choice (const w3) |
119 |
|
(const w3m) |
120 |
|
(const w3m-standalone) |
121 |
|
(const links) |
122 |
|
(const lynx) |
123 |
|
(const html2text) |
124 |
|
(const nil) |
125 |
|
(function)) |
126 |
|
:version "21.3" |
127 |
|
:group 'mime-display) |
128 |
|
|
129 |
|
(defvar mm-inline-text-html-renderer nil |
130 |
|
"Function used for rendering inline HTML contents. |
131 |
|
It is suggested to customize `mm-text-html-renderer' instead.") |
132 |
|
|
133 |
|
(defcustom mm-inline-text-html-with-images nil |
134 |
|
"If non-nil, Gnus will allow retrieving images in HTML contents with |
135 |
|
the <img> tags. It has no effect on Emacs/w3. See also the |
136 |
|
documentation for the `mm-w3m-safe-url-regexp' variable." |
137 |
|
:type 'boolean |
138 |
|
:group 'mime-display) |
139 |
|
|
140 |
|
(defcustom mm-w3m-safe-url-regexp "\\`cid:" |
141 |
|
"Regexp matching URLs which are considered to be safe. |
142 |
|
Some HTML mails might contain a nasty trick used by spammers, using |
143 |
|
the <img> tag which is far more evil than the [Click Here!] button. |
144 |
|
It is most likely intended to check whether the ominous spam mail has |
145 |
|
reached your eyes or not, in which case the spammer knows for sure |
146 |
|
that your email address is valid. It is done by embedding an |
147 |
|
identifier string into a URL that you might automatically retrieve |
148 |
|
when displaying the image. The default value is \"\\\\`cid:\" which only |
149 |
|
matches parts embedded to the Multipart/Related type MIME contents and |
150 |
|
Gnus will never connect to the spammer's site arbitrarily. You may |
151 |
|
set this variable to nil if you consider all urls to be safe." |
152 |
|
:type '(choice (regexp :tag "Regexp") |
153 |
|
(const :tag "All URLs are safe" nil)) |
154 |
|
:group 'mime-display) |
155 |
|
|
156 |
|
(defcustom mm-inline-text-html-with-w3m-keymap t |
157 |
|
"If non-nil, use emacs-w3m command keys in the article buffer." |
158 |
|
:type 'boolean |
159 |
|
:group 'mime-display) |
160 |
|
|
161 |
|
(defcustom mm-enable-external t |
162 |
|
"Indicate whether external MIME handlers should be used. |
163 |
|
|
164 |
|
If t, all defined external MIME handlers are used. If nil, files are saved by |
165 |
|
`mailcap-save-binary-file'. If it is the symbol `ask', you are prompted |
166 |
|
before the external MIME handler is invoked." |
167 |
|
:version "21.4" |
168 |
|
:type '(choice (const :tag "Always" t) |
169 |
|
(const :tag "Never" nil) |
170 |
|
(const :tag "Ask" ask)) |
171 |
|
:group 'mime-display) |
172 |
|
|
173 |
(defcustom mm-inline-media-tests |
(defcustom mm-inline-media-tests |
174 |
'(("image/jpeg" |
'(("image/p?jpeg" |
175 |
mm-inline-image |
mm-inline-image |
176 |
(lambda (handle) |
(lambda (handle) |
177 |
(mm-valid-and-fit-image-p 'jpeg handle))) |
(mm-valid-and-fit-image-p 'jpeg handle))) |
199 |
mm-inline-image |
mm-inline-image |
200 |
(lambda (handle) |
(lambda (handle) |
201 |
(mm-valid-and-fit-image-p 'xpm handle))) |
(mm-valid-and-fit-image-p 'xpm handle))) |
202 |
("image/x-pixmap" |
("image/x-xpixmap" |
203 |
mm-inline-image |
mm-inline-image |
204 |
(lambda (handle) |
(lambda (handle) |
205 |
(mm-valid-and-fit-image-p 'xpm handle))) |
(mm-valid-and-fit-image-p 'xpm handle))) |
218 |
(lambda (handle) |
(lambda (handle) |
219 |
(locate-library "diff-mode"))) |
(locate-library "diff-mode"))) |
220 |
("application/emacs-lisp" mm-display-elisp-inline identity) |
("application/emacs-lisp" mm-display-elisp-inline identity) |
221 |
|
("application/x-emacs-lisp" mm-display-elisp-inline identity) |
222 |
("text/html" |
("text/html" |
223 |
mm-inline-text |
mm-inline-text-html |
224 |
(lambda (handle) |
(lambda (handle) |
225 |
(locate-library "w3"))) |
(or mm-inline-text-html-renderer |
226 |
|
mm-text-html-renderer))) |
227 |
("text/x-vcard" |
("text/x-vcard" |
228 |
mm-inline-text |
mm-inline-text-vcard |
229 |
(lambda (handle) |
(lambda (handle) |
230 |
(or (featurep 'vcard) |
(or (featurep 'vcard) |
231 |
(locate-library "vcard")))) |
(locate-library "vcard")))) |
232 |
("message/delivery-status" mm-inline-text identity) |
("message/delivery-status" mm-inline-text identity) |
233 |
("message/rfc822" mm-inline-message identity) |
("message/rfc822" mm-inline-message identity) |
234 |
("message/partial" mm-inline-partial identity) |
("message/partial" mm-inline-partial identity) |
235 |
|
("message/external-body" mm-inline-external-body identity) |
236 |
("text/.*" mm-inline-text identity) |
("text/.*" mm-inline-text identity) |
237 |
("audio/wav" mm-inline-audio |
("audio/wav" mm-inline-audio |
238 |
(lambda (handle) |
(lambda (handle) |
244 |
(and (or (featurep 'nas-sound) (featurep 'native-sound)) |
(and (or (featurep 'nas-sound) (featurep 'native-sound)) |
245 |
(device-sound-enabled-p)))) |
(device-sound-enabled-p)))) |
246 |
("application/pgp-signature" ignore identity) |
("application/pgp-signature" ignore identity) |
247 |
|
("application/x-pkcs7-signature" ignore identity) |
248 |
|
("application/pkcs7-signature" ignore identity) |
249 |
|
("application/x-pkcs7-mime" ignore identity) |
250 |
|
("application/pkcs7-mime" ignore identity) |
251 |
("multipart/alternative" ignore identity) |
("multipart/alternative" ignore identity) |
252 |
("multipart/mixed" ignore identity) |
("multipart/mixed" ignore identity) |
253 |
("multipart/related" ignore identity)) |
("multipart/related" ignore identity) |
254 |
|
;; Disable audio and image |
255 |
|
("audio/.*" ignore ignore) |
256 |
|
("image/.*" ignore ignore) |
257 |
|
;; Default to displaying as text |
258 |
|
(".*" mm-inline-text mm-readable-p)) |
259 |
"Alist of media types/tests saying whether types can be displayed inline." |
"Alist of media types/tests saying whether types can be displayed inline." |
260 |
:type '(repeat (list (string :tag "MIME type") |
:type '(repeat (list (regexp :tag "MIME type") |
261 |
(function :tag "Display function") |
(function :tag "Display function") |
262 |
(function :tag "Display test"))) |
(function :tag "Display test"))) |
263 |
:group 'mime-display) |
:group 'mime-display) |
264 |
|
|
265 |
(defcustom mm-inlined-types |
(defcustom mm-inlined-types |
266 |
'("image/.*" "text/.*" "message/delivery-status" "message/rfc822" |
'("image/.*" "text/.*" "message/delivery-status" "message/rfc822" |
267 |
"message/partial" "application/emacs-lisp" |
"message/partial" "message/external-body" "application/emacs-lisp" |
268 |
"application/pgp-signature") |
"application/x-emacs-lisp" |
269 |
"List of media types that are to be displayed inline." |
"application/pgp-signature" "application/x-pkcs7-signature" |
270 |
|
"application/pkcs7-signature" "application/x-pkcs7-mime" |
271 |
|
"application/pkcs7-mime") |
272 |
|
"List of media types that are to be displayed inline. |
273 |
|
See also `mm-inline-media-tests', which says how to display a media |
274 |
|
type inline." |
275 |
|
:type '(repeat string) |
276 |
|
:group 'mime-display) |
277 |
|
|
278 |
|
(defcustom mm-keep-viewer-alive-types |
279 |
|
'("application/postscript" "application/msword" "application/vnd.ms-excel" |
280 |
|
"application/pdf" "application/x-dvi") |
281 |
|
"List of media types for which the external viewer will not be killed |
282 |
|
when selecting a different article." |
283 |
:type '(repeat string) |
:type '(repeat string) |
284 |
:group 'mime-display) |
:group 'mime-display) |
285 |
|
|
287 |
'("text/plain" "text/enriched" "text/richtext" "text/html" |
'("text/plain" "text/enriched" "text/richtext" "text/html" |
288 |
"text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" |
"text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" |
289 |
"message/rfc822" "text/x-patch" "application/pgp-signature" |
"message/rfc822" "text/x-patch" "application/pgp-signature" |
290 |
"application/emacs-lisp") |
"application/emacs-lisp" "application/x-emacs-lisp" |
291 |
|
"application/x-pkcs7-signature" |
292 |
|
"application/pkcs7-signature" "application/x-pkcs7-mime" |
293 |
|
"application/pkcs7-mime") |
294 |
"A list of MIME types to be displayed automatically." |
"A list of MIME types to be displayed automatically." |
295 |
:type '(repeat string) |
:type '(repeat string) |
296 |
:group 'mime-display) |
:group 'mime-display) |
297 |
|
|
298 |
(defcustom mm-attachment-override-types '("text/x-vcard") |
(defcustom mm-attachment-override-types '("text/x-vcard" |
299 |
|
"application/pkcs7-mime" |
300 |
|
"application/x-pkcs7-mime" |
301 |
|
"application/pkcs7-signature" |
302 |
|
"application/x-pkcs7-signature") |
303 |
"Types to have \"attachment\" ignored if they can be displayed inline." |
"Types to have \"attachment\" ignored if they can be displayed inline." |
304 |
:type '(repeat string) |
:type '(repeat string) |
305 |
:group 'mime-display) |
:group 'mime-display) |
327 |
:type '(repeat string) |
:type '(repeat string) |
328 |
:group 'mime-display) |
:group 'mime-display) |
329 |
|
|
330 |
(defvar mm-tmp-directory |
(defcustom mm-tmp-directory |
331 |
(cond ((fboundp 'temp-directory) (temp-directory)) |
(if (fboundp 'temp-directory) |
332 |
((boundp 'temporary-file-directory) temporary-file-directory) |
(temp-directory) |
333 |
("/tmp/")) |
(if (boundp 'temporary-file-directory) |
334 |
"Where mm will store its temporary files.") |
temporary-file-directory |
335 |
|
"/tmp/")) |
336 |
|
"Where mm will store its temporary files." |
337 |
|
:type 'directory |
338 |
|
:group 'mime-display) |
339 |
|
|
340 |
(defcustom mm-inline-large-images nil |
(defcustom mm-inline-large-images nil |
341 |
"If non-nil, then all images fit in the buffer." |
"If non-nil, then all images fit in the buffer." |
342 |
:type 'boolean |
:type 'boolean |
343 |
:group 'mime-display) |
:group 'mime-display) |
344 |
|
|
345 |
|
(defvar mm-file-name-rewrite-functions |
346 |
|
'(mm-file-name-delete-control mm-file-name-delete-gotchas) |
347 |
|
"*List of functions used for rewriting file names of MIME parts. |
348 |
|
Each function takes a file name as input and returns a file name. |
349 |
|
|
350 |
|
Ready-made functions include |
351 |
|
`mm-file-name-delete-control' |
352 |
|
`mm-file-name-delete-gotchas' |
353 |
|
`mm-file-name-delete-whitespace', |
354 |
|
`mm-file-name-trim-whitespace', |
355 |
|
`mm-file-name-collapse-whitespace', |
356 |
|
`mm-file-name-replace-whitespace', |
357 |
|
`capitalize', `downcase', `upcase', and |
358 |
|
`upcase-initials'.") |
359 |
|
|
360 |
|
(defvar mm-path-name-rewrite-functions nil |
361 |
|
"*List of functions for rewriting the full file names of MIME parts. |
362 |
|
This is used when viewing parts externally, and is meant for |
363 |
|
transforming the absolute name so that non-compliant programs can find |
364 |
|
the file where it's saved. |
365 |
|
|
366 |
|
Each function takes a file name as input and returns a file name.") |
367 |
|
|
368 |
|
(defvar mm-file-name-replace-whitespace nil |
369 |
|
"String used for replacing whitespace characters; default is `\"_\"'.") |
370 |
|
|
371 |
|
(defcustom mm-default-directory nil |
372 |
|
"The default directory where mm will save files. |
373 |
|
If not set, `default-directory' will be used." |
374 |
|
:type '(choice directory (const :tag "Default" nil)) |
375 |
|
:group 'mime-display) |
376 |
|
|
377 |
|
(defcustom mm-attachment-file-modes 384 |
378 |
|
"Set the mode bits of saved attachments to this integer." |
379 |
|
:type 'integer |
380 |
|
:group 'mime-display) |
381 |
|
|
382 |
|
(defcustom mm-external-terminal-program "xterm" |
383 |
|
"The program to start an external terminal." |
384 |
|
:type 'string |
385 |
|
:group 'mime-display) |
386 |
|
|
387 |
;;; Internal variables. |
;;; Internal variables. |
388 |
|
|
|
(defvar mm-dissection-list nil) |
|
389 |
(defvar mm-last-shell-command "") |
(defvar mm-last-shell-command "") |
390 |
(defvar mm-content-id-alist nil) |
(defvar mm-content-id-alist nil) |
391 |
|
(defvar mm-postponed-undisplay-list nil) |
392 |
|
|
393 |
;; According to RFC2046, in particular, in a digest, the default |
;; According to RFC2046, in particular, in a digest, the default |
394 |
;; Content-Type value for a body part is changed from "text/plain" to |
;; Content-Type value for a body part is changed from "text/plain" to |
395 |
;; "message/rfc822". |
;; "message/rfc822". |
396 |
(defvar mm-dissect-default-type "text/plain") |
(defvar mm-dissect-default-type "text/plain") |
397 |
|
|
398 |
|
(autoload 'mml2015-verify "mml2015") |
399 |
|
(autoload 'mml2015-verify-test "mml2015") |
400 |
|
(autoload 'mml-smime-verify "mml-smime") |
401 |
|
(autoload 'mml-smime-verify-test "mml-smime") |
402 |
|
|
403 |
|
(defvar mm-verify-function-alist |
404 |
|
'(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test) |
405 |
|
("application/x-gnus-pgp-signature" mm-uu-pgp-signed-extract-1 "PGP" |
406 |
|
mm-uu-pgp-signed-test) |
407 |
|
("application/pkcs7-signature" mml-smime-verify "S/MIME" |
408 |
|
mml-smime-verify-test) |
409 |
|
("application/x-pkcs7-signature" mml-smime-verify "S/MIME" |
410 |
|
mml-smime-verify-test))) |
411 |
|
|
412 |
|
(defcustom mm-verify-option 'never |
413 |
|
"Option of verifying signed parts. |
414 |
|
`never', not verify; `always', always verify; |
415 |
|
`known', only verify known protocols. Otherwise, ask user." |
416 |
|
:type '(choice (item always) |
417 |
|
(item never) |
418 |
|
(item :tag "only known protocols" known) |
419 |
|
(item :tag "ask" nil)) |
420 |
|
:group 'mime-security) |
421 |
|
|
422 |
|
(autoload 'mml2015-decrypt "mml2015") |
423 |
|
(autoload 'mml2015-decrypt-test "mml2015") |
424 |
|
|
425 |
|
(defvar mm-decrypt-function-alist |
426 |
|
'(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test) |
427 |
|
("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP" |
428 |
|
mm-uu-pgp-encrypted-test))) |
429 |
|
|
430 |
|
(defcustom mm-decrypt-option nil |
431 |
|
"Option of decrypting encrypted parts. |
432 |
|
`never', not decrypt; `always', always decrypt; |
433 |
|
`known', only decrypt known protocols. Otherwise, ask user." |
434 |
|
:type '(choice (item always) |
435 |
|
(item never) |
436 |
|
(item :tag "only known protocols" known) |
437 |
|
(item :tag "ask" nil)) |
438 |
|
:group 'mime-security) |
439 |
|
|
440 |
|
(defvar mm-viewer-completion-map |
441 |
|
(let ((map (make-sparse-keymap 'mm-viewer-completion-map))) |
442 |
|
(set-keymap-parent map minibuffer-local-completion-map) |
443 |
|
map) |
444 |
|
"Keymap for input viewer with completion.") |
445 |
|
|
446 |
|
;; Should we bind other key to minibuffer-complete-word? |
447 |
|
(define-key mm-viewer-completion-map " " 'self-insert-command) |
448 |
|
|
449 |
(defvar mm-viewer-completion-map |
(defvar mm-viewer-completion-map |
450 |
(let ((map (make-sparse-keymap 'mm-viewer-completion-map))) |
(let ((map (make-sparse-keymap 'mm-viewer-completion-map))) |
451 |
(set-keymap-parent map minibuffer-local-completion-map) |
(set-keymap-parent map minibuffer-local-completion-map) |
457 |
|
|
458 |
;;; The functions. |
;;; The functions. |
459 |
|
|
460 |
(defun mm-dissect-buffer (&optional no-strict-mime) |
(defun mm-alist-to-plist (alist) |
461 |
|
"Convert association list ALIST into the equivalent property-list form. |
462 |
|
The plist is returned. This converts from |
463 |
|
|
464 |
|
\((a . 1) (b . 2) (c . 3)) |
465 |
|
|
466 |
|
into |
467 |
|
|
468 |
|
\(a 1 b 2 c 3) |
469 |
|
|
470 |
|
The original alist is not modified. See also `destructive-alist-to-plist'." |
471 |
|
(let (plist) |
472 |
|
(while alist |
473 |
|
(let ((el (car alist))) |
474 |
|
(setq plist (cons (cdr el) (cons (car el) plist)))) |
475 |
|
(setq alist (cdr alist))) |
476 |
|
(nreverse plist))) |
477 |
|
|
478 |
|
(defun mm-keep-viewer-alive-p (handle) |
479 |
|
"Say whether external viewer for HANDLE should stay alive." |
480 |
|
(let ((types mm-keep-viewer-alive-types) |
481 |
|
(type (mm-handle-media-type handle)) |
482 |
|
ty) |
483 |
|
(catch 'found |
484 |
|
(while (setq ty (pop types)) |
485 |
|
(when (string-match ty type) |
486 |
|
(throw 'found t)))))) |
487 |
|
|
488 |
|
(defun mm-handle-set-external-undisplayer (handle function) |
489 |
|
"Set the undisplayer for HANDLE to FUNCTION. |
490 |
|
Postpone undisplaying of viewers for types in |
491 |
|
`mm-keep-viewer-alive-types'." |
492 |
|
(if (mm-keep-viewer-alive-p handle) |
493 |
|
(let ((new-handle (copy-sequence handle))) |
494 |
|
(mm-handle-set-undisplayer new-handle function) |
495 |
|
(mm-handle-set-undisplayer handle nil) |
496 |
|
(push new-handle mm-postponed-undisplay-list)) |
497 |
|
(mm-handle-set-undisplayer handle function))) |
498 |
|
|
499 |
|
(defun mm-destroy-postponed-undisplay-list () |
500 |
|
(when mm-postponed-undisplay-list |
501 |
|
(message "Destroying external MIME viewers") |
502 |
|
(mm-destroy-parts mm-postponed-undisplay-list))) |
503 |
|
|
504 |
|
(defun mm-dissect-buffer (&optional no-strict-mime loose-mime) |
505 |
"Dissect the current buffer and return a list of MIME handles." |
"Dissect the current buffer and return a list of MIME handles." |
506 |
(save-excursion |
(save-excursion |
507 |
(let (ct ctl type subtype cte cd description id result) |
(let (ct ctl type subtype cte cd description id result from) |
508 |
(save-restriction |
(save-restriction |
509 |
(mail-narrow-to-head) |
(mail-narrow-to-head) |
510 |
(when (or no-strict-mime |
(when (or no-strict-mime |
511 |
|
loose-mime |
512 |
(mail-fetch-field "mime-version")) |
(mail-fetch-field "mime-version")) |
513 |
(setq ct (mail-fetch-field "content-type") |
(setq ct (mail-fetch-field "content-type") |
514 |
ctl (ignore-errors (mail-header-parse-content-type ct)) |
ctl (ignore-errors (mail-header-parse-content-type ct)) |
515 |
cte (mail-fetch-field "content-transfer-encoding") |
cte (mail-fetch-field "content-transfer-encoding") |
516 |
cd (mail-fetch-field "content-disposition") |
cd (mail-fetch-field "content-disposition") |
517 |
description (mail-fetch-field "content-description") |
description (mail-fetch-field "content-description") |
518 |
id (mail-fetch-field "content-id")))) |
from (mail-fetch-field "from") |
519 |
|
id (mail-fetch-field "content-id")) |
520 |
|
;; FIXME: In some circumstances, this code is running within |
521 |
|
;; an unibyte macro. mail-extract-address-components |
522 |
|
;; creates unibyte buffers. This `if', though not a perfect |
523 |
|
;; solution, avoids most of them. |
524 |
|
(if from |
525 |
|
(setq from (cadr (mail-extract-address-components from)))))) |
526 |
(when cte |
(when cte |
527 |
(setq cte (mail-header-strip cte))) |
(setq cte (mail-header-strip cte))) |
528 |
(if (or (not ctl) |
(if (or (not ctl) |
544 |
((equal type "multipart") |
((equal type "multipart") |
545 |
(let ((mm-dissect-default-type (if (equal subtype "digest") |
(let ((mm-dissect-default-type (if (equal subtype "digest") |
546 |
"message/rfc822" |
"message/rfc822" |
547 |
"text/plain"))) |
"text/plain")) |
548 |
|
(start (cdr (assq 'start (cdr ctl))))) |
549 |
|
(add-text-properties 0 (length (car ctl)) |
550 |
|
(mm-alist-to-plist (cdr ctl)) (car ctl)) |
551 |
|
|
552 |
|
;; what really needs to be done here is a way to link a |
553 |
|
;; MIME handle back to it's parent MIME handle (in a multilevel |
554 |
|
;; MIME article). That would probably require changing |
555 |
|
;; the mm-handle API so we simply store the multipart buffert |
556 |
|
;; name as a text property of the "multipart/whatever" string. |
557 |
|
(add-text-properties 0 (length (car ctl)) |
558 |
|
(list 'buffer (mm-copy-to-buffer) |
559 |
|
'from from |
560 |
|
'start start) |
561 |
|
(car ctl)) |
562 |
(cons (car ctl) (mm-dissect-multipart ctl)))) |
(cons (car ctl) (mm-dissect-multipart ctl)))) |
563 |
(t |
(t |
564 |
(mm-dissect-singlepart |
(mm-possibly-verify-or-decrypt |
565 |
ctl |
(mm-dissect-singlepart |
566 |
(and cte (intern (downcase (mail-header-remove-whitespace |
ctl |
567 |
(mail-header-remove-comments |
(and cte (intern (downcase (mail-header-remove-whitespace |
568 |
cte))))) |
(mail-header-remove-comments |
569 |
no-strict-mime |
cte))))) |
570 |
(and cd (ignore-errors (mail-header-parse-content-disposition cd))) |
no-strict-mime |
571 |
description id)))) |
(and cd (ignore-errors |
572 |
|
(mail-header-parse-content-disposition cd))) |
573 |
|
description id) |
574 |
|
ctl)))) |
575 |
(when id |
(when id |
576 |
(when (string-match " *<\\(.*\\)> *" id) |
(when (string-match " *<\\(.*\\)> *" id) |
577 |
(setq id (match-string 1 id))) |
(setq id (match-string 1 id))) |
583 |
(if (equal "text/plain" (car ctl)) |
(if (equal "text/plain" (car ctl)) |
584 |
(assoc 'format ctl) |
(assoc 'format ctl) |
585 |
t)) |
t)) |
586 |
(let ((res (mm-make-handle |
(mm-make-handle |
587 |
(mm-copy-to-buffer) ctl cte nil cdl description nil id))) |
(mm-copy-to-buffer) ctl cte nil cdl description nil id))) |
|
(push (car res) mm-dissection-list) |
|
|
res))) |
|
|
|
|
|
(defun mm-remove-all-parts () |
|
|
"Remove all MIME handles." |
|
|
(interactive) |
|
|
(mapcar 'mm-remove-part mm-dissection-list) |
|
|
(setq mm-dissection-list nil)) |
|
588 |
|
|
589 |
(defun mm-dissect-multipart (ctl) |
(defun mm-dissect-multipart (ctl) |
590 |
(goto-char (point-min)) |
(goto-char (point-min)) |
604 |
(save-restriction |
(save-restriction |
605 |
(narrow-to-region start (point)) |
(narrow-to-region start (point)) |
606 |
(setq parts (nconc (list (mm-dissect-buffer t)) parts))))) |
(setq parts (nconc (list (mm-dissect-buffer t)) parts))))) |
607 |
(forward-line 2) |
(end-of-line 2) |
608 |
|
(or (looking-at boundary) |
609 |
|
(forward-line 1)) |
610 |
(setq start (point))) |
(setq start (point))) |
611 |
(when (and start (< start end)) |
(when (and start (< start end)) |
612 |
(save-excursion |
(save-excursion |
613 |
(save-restriction |
(save-restriction |
614 |
(narrow-to-region start end) |
(narrow-to-region start end) |
615 |
(setq parts (nconc (list (mm-dissect-buffer t)) parts))))) |
(setq parts (nconc (list (mm-dissect-buffer t)) parts))))) |
616 |
(nreverse parts))) |
(mm-possibly-verify-or-decrypt (nreverse parts) ctl))) |
617 |
|
|
618 |
(defun mm-copy-to-buffer () |
(defun mm-copy-to-buffer () |
619 |
"Copy the contents of the current buffer to a fresh buffer." |
"Copy the contents of the current buffer to a fresh buffer." |
627 |
(insert-buffer-substring obuf beg) |
(insert-buffer-substring obuf beg) |
628 |
(current-buffer)))) |
(current-buffer)))) |
629 |
|
|
630 |
|
(defun mm-display-parts (handle &optional no-default) |
631 |
|
(if (stringp (car handle)) |
632 |
|
(mapcar 'mm-display-parts (cdr handle)) |
633 |
|
(if (bufferp (car handle)) |
634 |
|
(save-restriction |
635 |
|
(narrow-to-region (point) (point)) |
636 |
|
(mm-display-part handle) |
637 |
|
(goto-char (point-max))) |
638 |
|
(mapcar 'mm-display-parts handle)))) |
639 |
|
|
640 |
(defun mm-display-part (handle &optional no-default) |
(defun mm-display-part (handle &optional no-default) |
641 |
"Display the MIME part represented by HANDLE. |
"Display the MIME part represented by HANDLE. |
642 |
Returns nil if the part is removed; inline if displayed inline; |
Returns nil if the part is removed; inline if displayed inline; |
646 |
(if (mm-handle-displayed-p handle) |
(if (mm-handle-displayed-p handle) |
647 |
(mm-remove-part handle) |
(mm-remove-part handle) |
648 |
(let* ((type (mm-handle-media-type handle)) |
(let* ((type (mm-handle-media-type handle)) |
649 |
(method (mailcap-mime-info type))) |
(method (mailcap-mime-info type)) |
650 |
(if (mm-inlined-p handle) |
(filename (or (mail-content-type-get |
651 |
|
(mm-handle-disposition handle) 'filename) |
652 |
|
(mail-content-type-get |
653 |
|
(mm-handle-type handle) 'name) |
654 |
|
"<file>")) |
655 |
|
(external mm-enable-external)) |
656 |
|
(if (and (mm-inlinable-p handle) |
657 |
|
(mm-inlined-p handle)) |
658 |
(progn |
(progn |
659 |
(forward-line 1) |
(forward-line 1) |
660 |
(mm-display-inline handle) |
(mm-display-inline handle) |
667 |
(forward-line 1) |
(forward-line 1) |
668 |
(mm-insert-inline handle (mm-get-part handle)) |
(mm-insert-inline handle (mm-get-part handle)) |
669 |
'inline) |
'inline) |
670 |
(mm-display-external |
(if (and method ;; If nil, we always use "save". |
671 |
handle (or method 'mailcap-save-binary-file))))))))) |
(stringp method) ;; 'mailcap-save-binary-file |
672 |
|
(or (eq mm-enable-external t) |
673 |
|
(and (eq mm-enable-external 'ask) |
674 |
|
(y-or-n-p |
675 |
|
(concat |
676 |
|
"Display part (" type |
677 |
|
") using external program" |
678 |
|
;; Can non-string method ever happen? |
679 |
|
(if (stringp method) |
680 |
|
(concat |
681 |
|
" \"" (format method filename) "\"") |
682 |
|
"") |
683 |
|
"? "))))) |
684 |
|
(setq external t) |
685 |
|
(setq external nil)) |
686 |
|
(if external |
687 |
|
(mm-display-external |
688 |
|
handle (or method 'mailcap-save-binary-file)) |
689 |
|
(mm-display-external |
690 |
|
handle 'mailcap-save-binary-file))))))))) |
691 |
|
|
692 |
(defun mm-display-external (handle method) |
(defun mm-display-external (handle method) |
693 |
"Display HANDLE using METHOD." |
"Display HANDLE using METHOD." |
704 |
(when win |
(when win |
705 |
(select-window win))) |
(select-window win))) |
706 |
(switch-to-buffer (generate-new-buffer " *mm*"))) |
(switch-to-buffer (generate-new-buffer " *mm*"))) |
707 |
|
(buffer-disable-undo) |
708 |
(mm-set-buffer-file-coding-system mm-binary-coding-system) |
(mm-set-buffer-file-coding-system mm-binary-coding-system) |
709 |
(insert-buffer-substring cur) |
(insert-buffer-substring cur) |
710 |
(goto-char (point-min)) |
(goto-char (point-min)) |
711 |
(message "Viewing with %s" method) |
(when method |
712 |
|
(message "Viewing with %s" method)) |
713 |
(let ((mm (current-buffer)) |
(let ((mm (current-buffer)) |
714 |
(non-viewer (assq 'non-viewer |
(non-viewer (assq 'non-viewer |
715 |
(mailcap-mime-info |
(mailcap-mime-info |
723 |
(mm-handle-set-undisplayer handle mm))))) |
(mm-handle-set-undisplayer handle mm))))) |
724 |
;; The function is a string to be executed. |
;; The function is a string to be executed. |
725 |
(mm-insert-part handle) |
(mm-insert-part handle) |
726 |
(let* ((dir (mm-make-temp-file |
(let* ((dir (mm-make-temp-file |
727 |
(expand-file-name "emm." mm-tmp-directory) 'dir)) |
(expand-file-name "emm." mm-tmp-directory) 'dir)) |
728 |
(filename (mail-content-type-get |
(filename (or |
729 |
(mm-handle-disposition handle) 'filename)) |
(mail-content-type-get |
730 |
|
(mm-handle-disposition handle) 'filename) |
731 |
|
(mail-content-type-get |
732 |
|
(mm-handle-type handle) 'name))) |
733 |
(mime-info (mailcap-mime-info |
(mime-info (mailcap-mime-info |
734 |
(mm-handle-media-type handle) t)) |
(mm-handle-media-type handle) t)) |
735 |
(needsterm (or (assoc "needsterm" mime-info) |
(needsterm (or (assoc "needsterm" mime-info) |
739 |
;; We create a private sub-directory where we store our files. |
;; We create a private sub-directory where we store our files. |
740 |
(set-file-modes dir 448) |
(set-file-modes dir 448) |
741 |
(if filename |
(if filename |
742 |
(setq file (expand-file-name (file-name-nondirectory filename) |
(setq file (expand-file-name |
743 |
dir)) |
(gnus-map-function mm-file-name-rewrite-functions |
744 |
|
(file-name-nondirectory filename)) |
745 |
|
dir)) |
746 |
(setq file (mm-make-temp-file (expand-file-name "mm." dir)))) |
(setq file (mm-make-temp-file (expand-file-name "mm." dir)))) |
747 |
(let ((coding-system-for-write mm-binary-coding-system)) |
(let ((coding-system-for-write mm-binary-coding-system)) |
748 |
(write-region (point-min) (point-max) file nil 'nomesg)) |
(write-region (point-min) (point-max) file nil 'nomesg)) |
749 |
(message "Viewing with %s" method) |
(message "Viewing with %s" method) |
750 |
(cond (needsterm |
(cond |
751 |
(unwind-protect |
(needsterm |
752 |
(start-process "*display*" nil |
(let ((command (mm-mailcap-command |
753 |
"xterm" |
method file (mm-handle-type handle)))) |
754 |
"-e" shell-file-name |
(unwind-protect |
755 |
shell-command-switch |
(if window-system |
756 |
(mm-mailcap-command |
(start-process "*display*" nil |
757 |
method file (mm-handle-type handle))) |
mm-external-terminal-program |
758 |
(mm-handle-set-undisplayer handle (cons file buffer))) |
"-e" shell-file-name |
759 |
(message "Displaying %s..." (format method file)) |
shell-command-switch command) |
760 |
'external) |
(require 'term) |
761 |
(copiousoutput |
(require 'gnus-win) |
762 |
(with-current-buffer outbuf |
(set-buffer |
763 |
(forward-line 1) |
(setq buffer |
764 |
(mm-insert-inline |
(make-term "display" |
765 |
handle |
shell-file-name |
766 |
(unwind-protect |
nil |
767 |
(progn |
shell-command-switch command))) |
768 |
(call-process shell-file-name nil |
(term-mode) |
769 |
(setq buffer |
(term-char-mode) |
770 |
(generate-new-buffer "*mm*")) |
(set-process-sentinel |
771 |
nil |
(get-buffer-process buffer) |
772 |
shell-command-switch |
`(lambda (process state) |
773 |
(mm-mailcap-command |
(if (eq 'exit (process-status process)) |
774 |
method file (mm-handle-type handle))) |
(gnus-configure-windows |
775 |
(if (buffer-live-p buffer) |
',gnus-current-window-configuration)))) |
776 |
(save-excursion |
(gnus-configure-windows 'display-term)) |
777 |
(set-buffer buffer) |
(mm-handle-set-external-undisplayer handle (cons file buffer))) |
778 |
(buffer-string)))) |
(message "Displaying %s..." command)) |
779 |
(progn |
'external) |
780 |
(ignore-errors (delete-file file)) |
(copiousoutput |
781 |
(ignore-errors (delete-directory |
(with-current-buffer outbuf |
782 |
(file-name-directory file))) |
(forward-line 1) |
783 |
(ignore-errors (kill-buffer buffer)))))) |
(mm-insert-inline |
784 |
'inline) |
handle |
785 |
(t |
(unwind-protect |
786 |
(unwind-protect |
(progn |
787 |
(start-process "*display*" |
(call-process shell-file-name nil |
788 |
(setq buffer |
(setq buffer |
789 |
(generate-new-buffer "*mm*")) |
(generate-new-buffer " *mm*")) |
790 |
shell-file-name |
nil |
791 |
shell-command-switch |
shell-command-switch |
792 |
(mm-mailcap-command |
(mm-mailcap-command |
793 |
method file (mm-handle-type handle))) |
method file (mm-handle-type handle))) |
794 |
(mm-handle-set-undisplayer handle (cons file buffer))) |
(if (buffer-live-p buffer) |
795 |
(message "Displaying %s..." (format method file)) |
(save-excursion |
796 |
'external))))))) |
(set-buffer buffer) |
797 |
|
(buffer-string)))) |
798 |
|
(progn |
799 |
|
(ignore-errors (delete-file file)) |
800 |
|
(ignore-errors (delete-directory |
801 |
|
(file-name-directory file))) |
802 |
|
(ignore-errors (kill-buffer buffer)))))) |
803 |
|
'inline) |
804 |
|
(t |
805 |
|
(let ((command (mm-mailcap-command |
806 |
|
method file (mm-handle-type handle)))) |
807 |
|
(unwind-protect |
808 |
|
(start-process "*display*" |
809 |
|
(setq buffer |
810 |
|
(generate-new-buffer " *mm*")) |
811 |
|
shell-file-name |
812 |
|
shell-command-switch command) |
813 |
|
(mm-handle-set-external-undisplayer |
814 |
|
handle (cons file buffer))) |
815 |
|
(message "Displaying %s..." command)) |
816 |
|
'external))))))) |
817 |
|
|
818 |
(defun mm-mailcap-command (method file type-list) |
(defun mm-mailcap-command (method file type-list) |
819 |
(let ((ctl (cdr type-list)) |
(let ((ctl (cdr type-list)) |
820 |
(beg 0) |
(beg 0) |
821 |
(uses-stdin t) |
(uses-stdin t) |
822 |
out sub total) |
out sub total) |
823 |
(while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg) |
(while (string-match "%{\\([^}]+\\)}\\|'%s'\\|\"%s\"\\|%s\\|%t\\|%%" |
824 |
|
method beg) |
825 |
(push (substring method beg (match-beginning 0)) out) |
(push (substring method beg (match-beginning 0)) out) |
826 |
(setq beg (match-end 0) |
(setq beg (match-end 0) |
827 |
total (match-string 0 method) |
total (match-string 0 method) |
829 |
(cond |
(cond |
830 |
((string= total "%%") |
((string= total "%%") |
831 |
(push "%" out)) |
(push "%" out)) |
832 |
((string= total "%s") |
((or (string= total "%s") |
833 |
|
;; We do our own quoting. |
834 |
|
(string= total "'%s'") |
835 |
|
(string= total "\"%s\"")) |
836 |
(setq uses-stdin nil) |
(setq uses-stdin nil) |
837 |
(push (mm-quote-arg file) out)) |
(push (mm-quote-arg |
838 |
|
(gnus-map-function mm-path-name-rewrite-functions file)) out)) |
839 |
((string= total "%t") |
((string= total "%t") |
840 |
(push (mm-quote-arg (car type-list)) out)) |
(push (mm-quote-arg (car type-list)) out)) |
841 |
(t |
(t |
842 |
(push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out)))) |
(push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out)))) |
843 |
(push (substring method beg (length method)) out) |
(push (substring method beg (length method)) out) |
844 |
(if uses-stdin |
(when uses-stdin |
845 |
(progn |
(push "<" out) |
846 |
(push "<" out) |
(push (mm-quote-arg |
847 |
(push (mm-quote-arg file) out))) |
(gnus-map-function mm-path-name-rewrite-functions file)) |
848 |
|
out)) |
849 |
(mapconcat 'identity (nreverse out) ""))) |
(mapconcat 'identity (nreverse out) ""))) |
850 |
|
|
851 |
(defun mm-remove-parts (handles) |
(defun mm-remove-parts (handles) |
857 |
(while (setq handle (pop handles)) |
(while (setq handle (pop handles)) |
858 |
(cond |
(cond |
859 |
((stringp handle) |
((stringp handle) |
860 |
;; Do nothing. |
(when (buffer-live-p (get-text-property 0 'buffer handle)) |
861 |
) |
(kill-buffer (get-text-property 0 'buffer handle)))) |
862 |
((and (listp handle) |
((and (listp handle) |
863 |
(stringp (car handle))) |
(stringp (car handle))) |
864 |
(mm-remove-parts (cdr handle))) |
(mm-remove-parts (cdr handle))) |
874 |
(while (setq handle (pop handles)) |
(while (setq handle (pop handles)) |
875 |
(cond |
(cond |
876 |
((stringp handle) |
((stringp handle) |
877 |
;; Do nothing. |
(when (buffer-live-p (get-text-property 0 'buffer handle)) |
878 |
) |
(kill-buffer (get-text-property 0 'buffer handle)))) |
879 |
((and (listp handle) |
((and (listp handle) |
880 |
(stringp (car handle))) |
(stringp (car handle))) |
881 |
(mm-destroy-parts (cdr handle))) |
(mm-destroy-parts handle)) |
882 |
(t |
(t |
883 |
(mm-destroy-part handle))))))) |
(mm-destroy-part handle))))))) |
884 |
|
|
897 |
(funcall object)) |
(funcall object)) |
898 |
;; Externally displayed part. |
;; Externally displayed part. |
899 |
((consp object) |
((consp object) |
900 |
|
(condition-case () |
901 |
|
(while (get-buffer-process (cdr object)) |
902 |
|
(interrupt-process (get-buffer-process (cdr object))) |
903 |
|
(message "Waiting for external displayer to die...") |
904 |
|
(sit-for 1)) |
905 |
|
(quit) |
906 |
|
(error)) |
907 |
|
(ignore-errors (and (cdr object) (kill-buffer (cdr object)))) |
908 |
|
(message "Waiting for external displayer to die...done") |
909 |
(ignore-errors (delete-file (car object))) |
(ignore-errors (delete-file (car object))) |
910 |
(ignore-errors (delete-directory (file-name-directory (car object)))) |
(ignore-errors (delete-directory (file-name-directory |
911 |
(ignore-errors (kill-buffer (cdr object)))) |
(car object))))) |
912 |
((bufferp object) |
((bufferp object) |
913 |
(when (buffer-live-p object) |
(when (buffer-live-p object) |
914 |
(kill-buffer object))))) |
(kill-buffer object))))) |
925 |
(when (string-match (car elem) type) |
(when (string-match (car elem) type) |
926 |
(return elem)))) |
(return elem)))) |
927 |
|
|
928 |
|
(defun mm-automatic-display-p (handle) |
929 |
|
"Say whether the user wants HANDLE to be displayed automatically." |
930 |
|
(let ((methods mm-automatic-display) |
931 |
|
(type (mm-handle-media-type handle)) |
932 |
|
method result) |
933 |
|
(while (setq method (pop methods)) |
934 |
|
(when (and (not (mm-inline-override-p handle)) |
935 |
|
(string-match method type)) |
936 |
|
(setq result t |
937 |
|
methods nil))) |
938 |
|
result)) |
939 |
|
|
940 |
(defun mm-inlinable-p (handle) |
(defun mm-inlinable-p (handle) |
941 |
"Say whether HANDLE can be displayed inline." |
"Say whether HANDLE can be displayed inline." |
942 |
(let ((alist mm-inline-media-tests) |
(let ((alist mm-inline-media-tests) |
950 |
(pop alist)) |
(pop alist)) |
951 |
test)) |
test)) |
952 |
|
|
|
(defun mm-automatic-display-p (handle) |
|
|
"Say whether the user wants HANDLE to be displayed automatically." |
|
|
(let ((methods mm-automatic-display) |
|
|
(type (mm-handle-media-type handle)) |
|
|
method result) |
|
|
(while (setq method (pop methods)) |
|
|
(when (and (not (mm-inline-override-p handle)) |
|
|
(string-match method type) |
|
|
(mm-inlinable-p handle)) |
|
|
(setq result t |
|
|
methods nil))) |
|
|
result)) |
|
|
|
|
953 |
(defun mm-inlined-p (handle) |
(defun mm-inlined-p (handle) |
954 |
"Say whether the user wants HANDLE to be displayed automatically." |
"Say whether the user wants HANDLE to be displayed inline." |
955 |
(let ((methods mm-inlined-types) |
(let ((methods mm-inlined-types) |
956 |
(type (mm-handle-media-type handle)) |
(type (mm-handle-media-type handle)) |
957 |
method result) |
method result) |
958 |
(while (setq method (pop methods)) |
(while (setq method (pop methods)) |
959 |
(when (and (not (mm-inline-override-p handle)) |
(when (and (not (mm-inline-override-p handle)) |
960 |
(string-match method type) |
(string-match method type)) |
|
(mm-inlinable-p handle)) |
|
961 |
(setq result t |
(setq result t |
962 |
methods nil))) |
methods nil))) |
963 |
result)) |
result)) |
1011 |
(defun mm-get-part (handle) |
(defun mm-get-part (handle) |
1012 |
"Return the contents of HANDLE as a string." |
"Return the contents of HANDLE as a string." |
1013 |
(mm-with-unibyte-buffer |
(mm-with-unibyte-buffer |
1014 |
(mm-insert-part handle) |
(insert (with-current-buffer (mm-handle-buffer handle) |
1015 |
|
(mm-with-unibyte-current-buffer |
1016 |
|
(buffer-string)))) |
1017 |
|
(mm-decode-content-transfer-encoding |
1018 |
|
(mm-handle-encoding handle) |
1019 |
|
(mm-handle-media-type handle)) |
1020 |
(buffer-string))) |
(buffer-string))) |
1021 |
|
|
1022 |
(defun mm-insert-part (handle) |
(defun mm-insert-part (handle) |
1025 |
(save-excursion |
(save-excursion |
1026 |
(if (member (mm-handle-media-supertype handle) '("text" "message")) |
(if (member (mm-handle-media-supertype handle) '("text" "message")) |
1027 |
(with-temp-buffer |
(with-temp-buffer |
1028 |
(insert-buffer-substring (mm-handle-buffer handle)) |
(insert-buffer-substring (mm-handle-buffer handle)) |
1029 |
(mm-decode-content-transfer-encoding |
(prog1 |
1030 |
(mm-handle-encoding handle) |
(mm-decode-content-transfer-encoding |
1031 |
(mm-handle-media-type handle)) |
(mm-handle-encoding handle) |
1032 |
(let ((temp (current-buffer))) |
(mm-handle-media-type handle)) |
1033 |
(set-buffer cur) |
(let ((temp (current-buffer))) |
1034 |
(insert-buffer-substring temp))) |
(set-buffer cur) |
1035 |
|
(insert-buffer-substring temp)))) |
1036 |
(mm-with-unibyte-buffer |
(mm-with-unibyte-buffer |
1037 |
(insert-buffer-substring (mm-handle-buffer handle)) |
(insert-buffer-substring (mm-handle-buffer handle)) |
1038 |
(mm-decode-content-transfer-encoding |
(prog1 |
1039 |
(mm-handle-encoding handle) |
(mm-decode-content-transfer-encoding |
1040 |
(mm-handle-media-type handle)) |
(mm-handle-encoding handle) |
1041 |
(let ((temp (current-buffer))) |
(mm-handle-media-type handle)) |
1042 |
(set-buffer cur) |
(let ((temp (current-buffer))) |
1043 |
(insert-buffer-substring temp))))))) |
(set-buffer cur) |
1044 |
|
(insert-buffer-substring temp)))))))) |
1045 |
|
|
1046 |
(defvar mm-default-directory nil) |
(defun mm-file-name-delete-whitespace (file-name) |
1047 |
|
"Remove all whitespace characters from FILE-NAME." |
1048 |
|
(while (string-match "\\s-+" file-name) |
1049 |
|
(setq file-name (replace-match "" t t file-name))) |
1050 |
|
file-name) |
1051 |
|
|
1052 |
|
(defun mm-file-name-trim-whitespace (file-name) |
1053 |
|
"Remove leading and trailing whitespace characters from FILE-NAME." |
1054 |
|
(when (string-match "\\`\\s-+" file-name) |
1055 |
|
(setq file-name (substring file-name (match-end 0)))) |
1056 |
|
(when (string-match "\\s-+\\'" file-name) |
1057 |
|
(setq file-name (substring file-name 0 (match-beginning 0)))) |
1058 |
|
file-name) |
1059 |
|
|
1060 |
|
(defun mm-file-name-collapse-whitespace (file-name) |
1061 |
|
"Collapse multiple whitespace characters in FILE-NAME." |
1062 |
|
(while (string-match "\\s-\\s-+" file-name) |
1063 |
|
(setq file-name (replace-match " " t t file-name))) |
1064 |
|
file-name) |
1065 |
|
|
1066 |
|
(defun mm-file-name-replace-whitespace (file-name) |
1067 |
|
"Replace whitespace characters in FILE-NAME with underscores. |
1068 |
|
Set the option `mm-file-name-replace-whitespace' to any other |
1069 |
|
string if you do not like underscores." |
1070 |
|
(let ((s (or mm-file-name-replace-whitespace "_"))) |
1071 |
|
(while (string-match "\\s-" file-name) |
1072 |
|
(setq file-name (replace-match s t t file-name)))) |
1073 |
|
file-name) |
1074 |
|
|
1075 |
|
(defun mm-file-name-delete-control (filename) |
1076 |
|
"Delete control characters from FILENAME." |
1077 |
|
(gnus-replace-in-string filename "[\x00-\x1f\x7f]" "")) |
1078 |
|
|
1079 |
|
(defun mm-file-name-delete-gotchas (filename) |
1080 |
|
"Delete shell gotchas from FILENAME." |
1081 |
|
(setq filename (gnus-replace-in-string filename "[<>|]" "")) |
1082 |
|
(gnus-replace-in-string filename "^[.-]+" "")) |
1083 |
|
|
1084 |
(defun mm-save-part (handle) |
(defun mm-save-part (handle) |
1085 |
"Write HANDLE to a file." |
"Write HANDLE to a file." |
1088 |
(mm-handle-disposition handle) 'filename)) |
(mm-handle-disposition handle) 'filename)) |
1089 |
file) |
file) |
1090 |
(when filename |
(when filename |
1091 |
(setq filename (file-name-nondirectory filename))) |
(setq filename (gnus-map-function mm-file-name-rewrite-functions |
1092 |
|
(file-name-nondirectory filename)))) |
1093 |
(setq file |
(setq file |
1094 |
(read-file-name "Save MIME part to: " |
(mm-with-multibyte |
1095 |
(expand-file-name |
(read-file-name "Save MIME part to: " |
1096 |
(or filename name "") |
(or mm-default-directory default-directory) |
1097 |
(or mm-default-directory default-directory)))) |
nil nil (or filename name "")))) |
1098 |
(setq mm-default-directory (file-name-directory file)) |
(setq mm-default-directory (file-name-directory file)) |
1099 |
(when (or (not (file-exists-p file)) |
(and (or (not (file-exists-p file)) |
1100 |
(yes-or-no-p (format "File %s already exists; overwrite? " |
(yes-or-no-p (format "File %s already exists; overwrite? " |
1101 |
file))) |
file))) |
1102 |
(mm-save-part-to-file handle file)))) |
(progn |
1103 |
|
(mm-save-part-to-file handle file) |
1104 |
|
file)))) |
1105 |
|
|
1106 |
(defun mm-save-part-to-file (handle file) |
(defun mm-save-part-to-file (handle file) |
1107 |
(mm-with-unibyte-buffer |
(mm-with-unibyte-buffer |
1108 |
(mm-insert-part handle) |
(mm-insert-part handle) |
1109 |
(let ((coding-system-for-write 'binary) |
(let ((coding-system-for-write 'binary) |
1110 |
|
(current-file-modes (default-file-modes)) |
1111 |
;; Don't re-compress .gz & al. Arguably we should make |
;; Don't re-compress .gz & al. Arguably we should make |
1112 |
;; `file-name-handler-alist' nil, but that would chop |
;; `file-name-handler-alist' nil, but that would chop |
1113 |
;; ange-ftp, which is reasonable to use here. |
;; ange-ftp, which is reasonable to use here. |
1114 |
(inhibit-file-name-operation 'write-region) |
(inhibit-file-name-operation 'write-region) |
1115 |
(inhibit-file-name-handlers |
(inhibit-file-name-handlers |
1116 |
(cons 'jka-compr-handler inhibit-file-name-handlers))) |
(cons 'jka-compr-handler inhibit-file-name-handlers))) |
1117 |
(write-region (point-min) (point-max) file)))) |
(set-default-file-modes mm-attachment-file-modes) |
1118 |
|
(unwind-protect |
1119 |
|
(write-region (point-min) (point-max) file) |
1120 |
|
(set-default-file-modes current-file-modes))))) |
1121 |
|
|
1122 |
(defun mm-pipe-part (handle) |
(defun mm-pipe-part (handle) |
1123 |
"Pipe HANDLE to a process." |
"Pipe HANDLE to a process." |
1126 |
(read-string "Shell command on MIME part: " mm-last-shell-command))) |
(read-string "Shell command on MIME part: " mm-last-shell-command))) |
1127 |
(mm-with-unibyte-buffer |
(mm-with-unibyte-buffer |
1128 |
(mm-insert-part handle) |
(mm-insert-part handle) |
1129 |
(shell-command-on-region (point-min) (point-max) command nil)))) |
(let ((coding-system-for-write 'binary)) |
1130 |
|
(shell-command-on-region (point-min) (point-max) command nil))))) |
1131 |
|
|
1132 |
(defun mm-interactively-view-part (handle) |
(defun mm-interactively-view-part (handle) |
1133 |
"Display HANDLE using METHOD." |
"Display HANDLE using METHOD." |
1180 |
"Return the handle(s) referred to by ID." |
"Return the handle(s) referred to by ID." |
1181 |
(cdr (assoc id mm-content-id-alist))) |
(cdr (assoc id mm-content-id-alist))) |
1182 |
|
|
1183 |
|
(defconst mm-image-type-regexps |
1184 |
|
'(("/\\*.*XPM.\\*/" . xpm) |
1185 |
|
("P[1-6]" . pbm) |
1186 |
|
("GIF8" . gif) |
1187 |
|
("\377\330" . jpeg) |
1188 |
|
("\211PNG\r\n" . png) |
1189 |
|
("#define" . xbm) |
1190 |
|
("\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff) |
1191 |
|
("%!PS" . postscript)) |
1192 |
|
"Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types. |
1193 |
|
When the first bytes of an image file match REGEXP, it is assumed to |
1194 |
|
be of image type IMAGE-TYPE.") |
1195 |
|
|
1196 |
|
;; Steal from image.el. image-type-from-data suffers multi-line matching bug. |
1197 |
|
(defun mm-image-type-from-buffer () |
1198 |
|
"Determine the image type from data in the current buffer. |
1199 |
|
Value is a symbol specifying the image type or nil if type cannot |
1200 |
|
be determined." |
1201 |
|
(let ((types mm-image-type-regexps) |
1202 |
|
type) |
1203 |
|
(goto-char (point-min)) |
1204 |
|
(while (and types (null type)) |
1205 |
|
(let ((regexp (car (car types))) |
1206 |
|
(image-type (cdr (car types)))) |
1207 |
|
(when (looking-at regexp) |
1208 |
|
(setq type image-type)) |
1209 |
|
(setq types (cdr types)))) |
1210 |
|
type)) |
1211 |
|
|
1212 |
(defun mm-get-image (handle) |
(defun mm-get-image (handle) |
1213 |
"Return an image instance based on HANDLE." |
"Return an image instance based on HANDLE." |
1214 |
(let ((type (mm-handle-media-subtype handle)) |
(let ((type (mm-handle-media-subtype handle)) |
1229 |
(prog1 |
(prog1 |
1230 |
(setq spec |
(setq spec |
1231 |
(ignore-errors |
(ignore-errors |
1232 |
;; Avoid testing `make-glyph' since W3 may define |
;; Avoid testing `make-glyph' since W3 may define |
1233 |
;; a bogus version of it. |
;; a bogus version of it. |
1234 |
(if (fboundp 'create-image) |
(if (fboundp 'create-image) |
1235 |
(create-image (buffer-string) (intern type) 'data-p) |
(create-image (buffer-string) |
1236 |
(cond |
(or (mm-image-type-from-buffer) |
1237 |
((equal type "xbm") |
(intern type)) |
1238 |
;; xbm images require special handling, since |
'data-p) |
1239 |
;; the only way to create glyphs from these |
(mm-create-image-xemacs type)))) |
|
;; (without a ton of work) is to write them |
|
|
;; out to a file, and then create a file |
|
|
;; specifier. |
|
|
(let ((file (mm-make-temp-file |
|
|
(expand-file-name "emm.xbm" |
|
|
mm-tmp-directory)))) |
|
|
(unwind-protect |
|
|
(progn |
|
|
(write-region (point-min) (point-max) file) |
|
|
(make-glyph (list (cons 'x file)))) |
|
|
(ignore-errors |
|
|
(delete-file file))))) |
|
|
(t |
|
|
(make-glyph |
|
|
(vector (intern type) :data (buffer-string)))))))) |
|
1240 |
(mm-handle-set-cache handle spec)))))) |
(mm-handle-set-cache handle spec)))))) |
1241 |
|
|
1242 |
|
(defun mm-create-image-xemacs (type) |
1243 |
|
(cond |
1244 |
|
((equal type "xbm") |
1245 |
|
;; xbm images require special handling, since |
1246 |
|
;; the only way to create glyphs from these |
1247 |
|
;; (without a ton of work) is to write them |
1248 |
|
;; out to a file, and then create a file |
1249 |
|
;; specifier. |
1250 |
|
(let ((file (mm-make-temp-file |
1251 |
|
(expand-file-name "emm.xbm" |
1252 |
|
mm-tmp-directory)))) |
1253 |
|
(unwind-protect |
1254 |
|
(progn |
1255 |
|
(write-region (point-min) (point-max) file) |
1256 |
|
(make-glyph (list (cons 'x file)))) |
1257 |
|
(ignore-errors |
1258 |
|
(delete-file file))))) |
1259 |
|
(t |
1260 |
|
(make-glyph |
1261 |
|
(vector |
1262 |
|
(or (mm-image-type-from-buffer) |
1263 |
|
(intern type)) |
1264 |
|
:data (buffer-string)))))) |
1265 |
|
|
1266 |
(defun mm-image-fit-p (handle) |
(defun mm-image-fit-p (handle) |
1267 |
"Say whether the image in HANDLE will fit the current window." |
"Say whether the image in HANDLE will fit the current window." |
1268 |
(let ((image (mm-get-image handle))) |
(let ((image (mm-get-image handle))) |
1298 |
(and (mm-valid-image-format-p format) |
(and (mm-valid-image-format-p format) |
1299 |
(mm-image-fit-p handle))) |
(mm-image-fit-p handle))) |
1300 |
|
|
1301 |
|
(defun mm-find-part-by-type (handles type &optional notp recursive) |
1302 |
|
"Search in HANDLES for part with TYPE. |
1303 |
|
If NOTP, returns first non-matching part. |
1304 |
|
If RECURSIVE, search recursively." |
1305 |
|
(let (handle) |
1306 |
|
(while handles |
1307 |
|
(if (and recursive (stringp (caar handles))) |
1308 |
|
(if (setq handle (mm-find-part-by-type (cdar handles) type |
1309 |
|
notp recursive)) |
1310 |
|
(setq handles nil)) |
1311 |
|
(if (if notp |
1312 |
|
(not (equal (mm-handle-media-type (car handles)) type)) |
1313 |
|
(equal (mm-handle-media-type (car handles)) type)) |
1314 |
|
(setq handle (car handles) |
1315 |
|
handles nil))) |
1316 |
|
(setq handles (cdr handles))) |
1317 |
|
handle)) |
1318 |
|
|
1319 |
|
(defun mm-find-raw-part-by-type (ctl type &optional notp) |
1320 |
|
(goto-char (point-min)) |
1321 |
|
(let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl |
1322 |
|
'boundary))) |
1323 |
|
(close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$")) |
1324 |
|
start |
1325 |
|
(end (save-excursion |
1326 |
|
(goto-char (point-max)) |
1327 |
|
(if (re-search-backward close-delimiter nil t) |
1328 |
|
(match-beginning 0) |
1329 |
|
(point-max)))) |
1330 |
|
result) |
1331 |
|
(setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$")) |
1332 |
|
(while (and (not result) |
1333 |
|
(re-search-forward boundary end t)) |
1334 |
|
(goto-char (match-beginning 0)) |
1335 |
|
(when start |
1336 |
|
(save-excursion |
1337 |
|
(save-restriction |
1338 |
|
(narrow-to-region start (1- (point))) |
1339 |
|
(when (let ((ctl (ignore-errors |
1340 |
|
(mail-header-parse-content-type |
1341 |
|
(mail-fetch-field "content-type"))))) |
1342 |
|
(if notp |
1343 |
|
(not (equal (car ctl) type)) |
1344 |
|
(equal (car ctl) type))) |
1345 |
|
(setq result (buffer-string)))))) |
1346 |
|
(forward-line 1) |
1347 |
|
(setq start (point))) |
1348 |
|
(when (and (not result) start) |
1349 |
|
(save-excursion |
1350 |
|
(save-restriction |
1351 |
|
(narrow-to-region start end) |
1352 |
|
(when (let ((ctl (ignore-errors |
1353 |
|
(mail-header-parse-content-type |
1354 |
|
(mail-fetch-field "content-type"))))) |
1355 |
|
(if notp |
1356 |
|
(not (equal (car ctl) type)) |
1357 |
|
(equal (car ctl) type))) |
1358 |
|
(setq result (buffer-string)))))) |
1359 |
|
result)) |
1360 |
|
|
1361 |
|
(defvar mm-security-handle nil) |
1362 |
|
|
1363 |
|
(defsubst mm-set-handle-multipart-parameter (handle parameter value) |
1364 |
|
;; HANDLE could be a CTL. |
1365 |
|
(when handle |
1366 |
|
(put-text-property 0 (length (car handle)) parameter value |
1367 |
|
(car handle)))) |
1368 |
|
|
1369 |
|
(defun mm-possibly-verify-or-decrypt (parts ctl) |
1370 |
|
(let ((type (car ctl)) |
1371 |
|
(subtype (cadr (split-string (car ctl) "/"))) |
1372 |
|
(mm-security-handle ctl) ;; (car CTL) is the type. |
1373 |
|
protocol func functest) |
1374 |
|
(cond |
1375 |
|
((or (equal type "application/x-pkcs7-mime") |
1376 |
|
(equal type "application/pkcs7-mime")) |
1377 |
|
(with-temp-buffer |
1378 |
|
(when (and (cond |
1379 |
|
((eq mm-decrypt-option 'never) nil) |
1380 |
|
((eq mm-decrypt-option 'always) t) |
1381 |
|
((eq mm-decrypt-option 'known) t) |
1382 |
|
(t (y-or-n-p |
1383 |
|
(format "Decrypt (S/MIME) part? ")))) |
1384 |
|
(mm-view-pkcs7 parts)) |
1385 |
|
(setq parts (mm-dissect-buffer t))))) |
1386 |
|
((equal subtype "signed") |
1387 |
|
(unless (and (setq protocol |
1388 |
|
(mm-handle-multipart-ctl-parameter ctl 'protocol)) |
1389 |
|
(not (equal protocol "multipart/mixed"))) |
1390 |
|
;; The message is broken or draft-ietf-openpgp-multsig-01. |
1391 |
|
(let ((protocols mm-verify-function-alist)) |
1392 |
|
(while protocols |
1393 |
|
(if (and (or (not (setq functest (nth 3 (car protocols)))) |
1394 |
|
(funcall functest parts ctl)) |
1395 |
|
(mm-find-part-by-type parts (caar protocols) nil t)) |
1396 |
|
(setq protocol (caar protocols) |
1397 |
|
protocols nil) |
1398 |
|
(setq protocols (cdr protocols)))))) |
1399 |
|
(setq func (nth 1 (assoc protocol mm-verify-function-alist))) |
1400 |
|
(when (cond |
1401 |
|
((eq mm-verify-option 'never) nil) |
1402 |
|
((eq mm-verify-option 'always) t) |
1403 |
|
((eq mm-verify-option 'known) |
1404 |
|
(and func |
1405 |
|
(or (not (setq functest |
1406 |
|
(nth 3 (assoc protocol |
1407 |
|
mm-verify-function-alist)))) |
1408 |
|
(funcall functest parts ctl)))) |
1409 |
|
(t |
1410 |
|
(y-or-n-p |
1411 |
|
(format "Verify signed (%s) part? " |
1412 |
|
(or (nth 2 (assoc protocol mm-verify-function-alist)) |
1413 |
|
(format "protocol=%s" protocol)))))) |
1414 |
|
(save-excursion |
1415 |
|
(if func |
1416 |
|
(funcall func parts ctl) |
1417 |
|
(mm-set-handle-multipart-parameter |
1418 |
|
mm-security-handle 'gnus-details |
1419 |
|
(format "Unknown sign protocol (%s)" protocol)))))) |
1420 |
|
((equal subtype "encrypted") |
1421 |
|
(unless (setq protocol |
1422 |
|
(mm-handle-multipart-ctl-parameter ctl 'protocol)) |
1423 |
|
;; The message is broken. |
1424 |
|
(let ((parts parts)) |
1425 |
|
(while parts |
1426 |
|
(if (assoc (mm-handle-media-type (car parts)) |
1427 |
|
mm-decrypt-function-alist) |
1428 |
|
(setq protocol (mm-handle-media-type (car parts)) |
1429 |
|
parts nil) |
1430 |
|
(setq parts (cdr parts)))))) |
1431 |
|
(setq func (nth 1 (assoc protocol mm-decrypt-function-alist))) |
1432 |
|
(when (cond |
1433 |
|
((eq mm-decrypt-option 'never) nil) |
1434 |
|
((eq mm-decrypt-option 'always) t) |
1435 |
|
((eq mm-decrypt-option 'known) |
1436 |
|
(and func |
1437 |
|
(or (not (setq functest |
1438 |
|
(nth 3 (assoc protocol |
1439 |
|
mm-decrypt-function-alist)))) |
1440 |
|
(funcall functest parts ctl)))) |
1441 |
|
(t |
1442 |
|
(y-or-n-p |
1443 |
|
(format "Decrypt (%s) part? " |
1444 |
|
(or (nth 2 (assoc protocol mm-decrypt-function-alist)) |
1445 |
|
(format "protocol=%s" protocol)))))) |
1446 |
|
(save-excursion |
1447 |
|
(if func |
1448 |
|
(setq parts (funcall func parts ctl)) |
1449 |
|
(mm-set-handle-multipart-parameter |
1450 |
|
mm-security-handle 'gnus-details |
1451 |
|
(format "Unknown encrypt protocol (%s)" protocol)))))) |
1452 |
|
(t nil)) |
1453 |
|
parts)) |
1454 |
|
|
1455 |
|
(defun mm-multiple-handles (handles) |
1456 |
|
(and (listp handles) |
1457 |
|
(> (length handles) 1) |
1458 |
|
(or (listp (car handles)) |
1459 |
|
(stringp (car handles))))) |
1460 |
|
|
1461 |
|
(defun mm-complicated-handles (handles) |
1462 |
|
(and (listp (car handles)) |
1463 |
|
(> (length handles) 1))) |
1464 |
|
|
1465 |
|
(defun mm-merge-handles (handles1 handles2) |
1466 |
|
(append |
1467 |
|
(if (listp (car handles1)) |
1468 |
|
handles1 |
1469 |
|
(list handles1)) |
1470 |
|
(if (listp (car handles2)) |
1471 |
|
handles2 |
1472 |
|
(list handles2)))) |
1473 |
|
|
1474 |
|
(defun mm-readable-p (handle) |
1475 |
|
"Say whether the content of HANDLE is readable." |
1476 |
|
(and (< (with-current-buffer (mm-handle-buffer handle) |
1477 |
|
(buffer-size)) 10000) |
1478 |
|
(mm-with-unibyte-buffer |
1479 |
|
(mm-insert-part handle) |
1480 |
|
(and (eq (mm-body-7-or-8) '7bit) |
1481 |
|
(not (mm-long-lines-p 76)))))) |
1482 |
|
|
1483 |
(provide 'mm-decode) |
(provide 'mm-decode) |
1484 |
|
|
1485 |
;;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b |
;;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b |