Mercurial > emacs
annotate lisp/gnus/mm-decode.el @ 33308:3b044ee2f94a
Fernandez' icon renamed.
author | Dave Love <fx@gnu.org> |
---|---|
date | Wed, 08 Nov 2000 17:06:19 +0000 |
parents | acb605e6da0e |
children | e06db3b8e558 |
rev | line source |
---|---|
31717 | 1 ;;; mm-decode.el --- Functions for decoding MIME things |
2 ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. | |
3 | |
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | |
5 ;; MORIOKA Tomohiko <morioka@jaist.ac.jp> | |
32962 | 6 ;; Maintainer: bugs@gnus.org |
31717 | 7 ;; This file is part of GNU Emacs. |
8 | |
9 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 ;; it under the terms of the GNU General Public License as published by | |
11 ;; the Free Software Foundation; either version 2, or (at your option) | |
12 ;; any later version. | |
13 | |
14 ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 ;; GNU General Public License for more details. | |
18 | |
19 ;; You should have received a copy of the GNU General Public License | |
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
22 ;; Boston, MA 02111-1307, USA. | |
23 | |
24 ;;; Commentary: | |
25 | |
26 ;;; Code: | |
27 | |
28 (require 'mail-parse) | |
29 (require 'mailcap) | |
30 (require 'mm-bodies) | |
31 (eval-when-compile (require 'cl)) | |
32 | |
33 (eval-and-compile | |
33296 | 34 (autoload 'mm-inline-partial "mm-partial") |
35 (autoload 'mm-insert-inline "mm-view")) | |
31717 | 36 |
37 (defgroup mime-display () | |
38 "Display of MIME in mail and news articles." | |
39 :link '(custom-manual "(emacs-mime)Customization") | |
40 :version "21.1" | |
41 :group 'mail | |
42 :group 'news | |
43 :group 'multimedia) | |
44 | |
45 ;;; Convenience macros. | |
46 | |
47 (defmacro mm-handle-buffer (handle) | |
48 `(nth 0 ,handle)) | |
49 (defmacro mm-handle-type (handle) | |
50 `(nth 1 ,handle)) | |
51 (defsubst mm-handle-media-type (handle) | |
52 (if (stringp (car handle)) | |
53 (car handle) | |
54 (car (mm-handle-type handle)))) | |
55 (defsubst mm-handle-media-supertype (handle) | |
56 (car (split-string (mm-handle-media-type handle) "/"))) | |
57 (defsubst mm-handle-media-subtype (handle) | |
58 (cadr (split-string (mm-handle-media-type handle) "/"))) | |
59 (defmacro mm-handle-encoding (handle) | |
60 `(nth 2 ,handle)) | |
61 (defmacro mm-handle-undisplayer (handle) | |
62 `(nth 3 ,handle)) | |
63 (defmacro mm-handle-set-undisplayer (handle function) | |
64 `(setcar (nthcdr 3 ,handle) ,function)) | |
65 (defmacro mm-handle-disposition (handle) | |
66 `(nth 4 ,handle)) | |
67 (defmacro mm-handle-description (handle) | |
68 `(nth 5 ,handle)) | |
69 (defmacro mm-handle-cache (handle) | |
70 `(nth 6 ,handle)) | |
71 (defmacro mm-handle-set-cache (handle contents) | |
72 `(setcar (nthcdr 6 ,handle) ,contents)) | |
73 (defmacro mm-handle-id (handle) | |
74 `(nth 7 ,handle)) | |
75 (defmacro mm-make-handle (&optional buffer type encoding undisplayer | |
76 disposition description cache | |
77 id) | |
78 `(list ,buffer ,type ,encoding ,undisplayer | |
79 ,disposition ,description ,cache ,id)) | |
80 | |
81 (defcustom mm-inline-media-tests | |
82 '(("image/jpeg" | |
83 mm-inline-image | |
84 (lambda (handle) | |
85 (mm-valid-and-fit-image-p 'jpeg handle))) | |
86 ("image/png" | |
87 mm-inline-image | |
88 (lambda (handle) | |
89 (mm-valid-and-fit-image-p 'png handle))) | |
90 ("image/gif" | |
91 mm-inline-image | |
92 (lambda (handle) | |
93 (mm-valid-and-fit-image-p 'gif handle))) | |
94 ("image/tiff" | |
95 mm-inline-image | |
96 (lambda (handle) | |
97 (mm-valid-and-fit-image-p 'tiff handle)) ) | |
98 ("image/xbm" | |
99 mm-inline-image | |
100 (lambda (handle) | |
101 (mm-valid-and-fit-image-p 'xbm handle))) | |
102 ("image/x-xbitmap" | |
103 mm-inline-image | |
104 (lambda (handle) | |
105 (mm-valid-and-fit-image-p 'xbm handle))) | |
106 ("image/xpm" | |
107 mm-inline-image | |
108 (lambda (handle) | |
109 (mm-valid-and-fit-image-p 'xpm handle))) | |
110 ("image/x-pixmap" | |
111 mm-inline-image | |
112 (lambda (handle) | |
113 (mm-valid-and-fit-image-p 'xpm handle))) | |
114 ("image/bmp" | |
115 mm-inline-image | |
116 (lambda (handle) | |
117 (mm-valid-and-fit-image-p 'bmp handle))) | |
118 ("text/plain" mm-inline-text identity) | |
119 ("text/enriched" mm-inline-text identity) | |
120 ("text/richtext" mm-inline-text identity) | |
121 ("text/x-patch" mm-display-patch-inline | |
122 (lambda (handle) | |
123 (locate-library "diff-mode"))) | |
31764 | 124 ("application/emacs-lisp" mm-display-elisp-inline identity) |
31717 | 125 ("text/html" |
126 mm-inline-text | |
127 (lambda (handle) | |
128 (locate-library "w3"))) | |
129 ("text/x-vcard" | |
130 mm-inline-text | |
131 (lambda (handle) | |
132 (or (featurep 'vcard) | |
133 (locate-library "vcard")))) | |
134 ("message/delivery-status" mm-inline-text identity) | |
135 ("message/rfc822" mm-inline-message identity) | |
136 ("message/partial" mm-inline-partial identity) | |
137 ("text/.*" mm-inline-text identity) | |
138 ("audio/wav" mm-inline-audio | |
139 (lambda (handle) | |
140 (and (or (featurep 'nas-sound) (featurep 'native-sound)) | |
141 (device-sound-enabled-p)))) | |
142 ("audio/au" | |
143 mm-inline-audio | |
144 (lambda (handle) | |
145 (and (or (featurep 'nas-sound) (featurep 'native-sound)) | |
146 (device-sound-enabled-p)))) | |
147 ("application/pgp-signature" ignore identity) | |
148 ("multipart/alternative" ignore identity) | |
149 ("multipart/mixed" ignore identity) | |
150 ("multipart/related" ignore identity)) | |
151 "Alist of media types/tests saying whether types can be displayed inline." | |
152 :type '(repeat (list (string :tag "MIME type") | |
153 (function :tag "Display function") | |
154 (function :tag "Display test"))) | |
155 :group 'mime-display) | |
156 | |
157 (defcustom mm-inlined-types | |
158 '("image/.*" "text/.*" "message/delivery-status" "message/rfc822" | |
31764 | 159 "message/partial" "application/emacs-lisp" |
31717 | 160 "application/pgp-signature") |
161 "List of media types that are to be displayed inline." | |
162 :type '(repeat string) | |
163 :group 'mime-display) | |
164 | |
165 (defcustom mm-automatic-display | |
166 '("text/plain" "text/enriched" "text/richtext" "text/html" | |
167 "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" | |
31764 | 168 "message/rfc822" "text/x-patch" "application/pgp-signature" |
169 "application/emacs-lisp") | |
31717 | 170 "A list of MIME types to be displayed automatically." |
171 :type '(repeat string) | |
172 :group 'mime-display) | |
173 | |
174 (defcustom mm-attachment-override-types '("text/x-vcard") | |
175 "Types to have \"attachment\" ignored if they can be displayed inline." | |
176 :type '(repeat string) | |
177 :group 'mime-display) | |
178 | |
179 (defcustom mm-inline-override-types nil | |
180 "Types to be treated as attachments even if they can be displayed inline." | |
181 :type '(repeat string) | |
182 :group 'mime-display) | |
183 | |
184 (defcustom mm-automatic-external-display nil | |
185 "List of MIME type regexps that will be displayed externally automatically." | |
186 :type '(repeat string) | |
187 :group 'mime-display) | |
188 | |
189 (defcustom mm-discouraged-alternatives nil | |
190 "List of MIME types that are discouraged when viewing multipart/alternative. | |
191 Viewing agents are supposed to view the last possible part of a message, | |
192 as that is supposed to be the richest. However, users may prefer other | |
193 types instead, and this list says what types are most unwanted. If, | |
194 for instance, text/html parts are very unwanted, and text/richtext are | |
195 somewhat unwanted, then the value of this variable should be set | |
196 to: | |
197 | |
198 (\"text/html\" \"text/richtext\")" | |
199 :type '(repeat string) | |
200 :group 'mime-display) | |
201 | |
202 (defvar mm-tmp-directory | |
203 (cond ((fboundp 'temp-directory) (temp-directory)) | |
204 ((boundp 'temporary-file-directory) temporary-file-directory) | |
205 ("/tmp/")) | |
206 "Where mm will store its temporary files.") | |
207 | |
208 (defcustom mm-inline-large-images nil | |
209 "If non-nil, then all images fit in the buffer." | |
210 :type 'boolean | |
211 :group 'mime-display) | |
212 | |
213 ;;; Internal variables. | |
214 | |
215 (defvar mm-dissection-list nil) | |
216 (defvar mm-last-shell-command "") | |
217 (defvar mm-content-id-alist nil) | |
218 | |
219 ;; According to RFC2046, in particular, in a digest, the default | |
220 ;; Content-Type value for a body part is changed from "text/plain" to | |
221 ;; "message/rfc822". | |
222 (defvar mm-dissect-default-type "text/plain") | |
223 | |
32962 | 224 (defvar mm-viewer-completion-map |
225 (let ((map (make-sparse-keymap 'mm-viewer-completion-map))) | |
226 (set-keymap-parent map minibuffer-local-completion-map) | |
227 map) | |
228 "Keymap for input viewer with completion.") | |
229 | |
230 ;; Should we bind other key to minibuffer-complete-word? | |
231 (define-key mm-viewer-completion-map " " 'self-insert-command) | |
232 | |
31717 | 233 ;;; The functions. |
234 | |
235 (defun mm-dissect-buffer (&optional no-strict-mime) | |
236 "Dissect the current buffer and return a list of MIME handles." | |
237 (save-excursion | |
238 (let (ct ctl type subtype cte cd description id result) | |
239 (save-restriction | |
240 (mail-narrow-to-head) | |
241 (when (or no-strict-mime | |
242 (mail-fetch-field "mime-version")) | |
243 (setq ct (mail-fetch-field "content-type") | |
244 ctl (ignore-errors (mail-header-parse-content-type ct)) | |
245 cte (mail-fetch-field "content-transfer-encoding") | |
246 cd (mail-fetch-field "content-disposition") | |
247 description (mail-fetch-field "content-description") | |
248 id (mail-fetch-field "content-id")))) | |
249 (when cte | |
250 (setq cte (mail-header-strip cte))) | |
251 (if (or (not ctl) | |
252 (not (string-match "/" (car ctl)))) | |
253 (mm-dissect-singlepart | |
254 (list mm-dissect-default-type) | |
255 (and cte (intern (downcase (mail-header-remove-whitespace | |
256 (mail-header-remove-comments | |
257 cte))))) | |
258 no-strict-mime | |
259 (and cd (ignore-errors (mail-header-parse-content-disposition cd))) | |
260 description) | |
261 (setq type (split-string (car ctl) "/")) | |
262 (setq subtype (cadr type) | |
263 type (pop type)) | |
264 (setq | |
265 result | |
266 (cond | |
267 ((equal type "multipart") | |
268 (let ((mm-dissect-default-type (if (equal subtype "digest") | |
269 "message/rfc822" | |
270 "text/plain"))) | |
271 (cons (car ctl) (mm-dissect-multipart ctl)))) | |
272 (t | |
273 (mm-dissect-singlepart | |
274 ctl | |
275 (and cte (intern (downcase (mail-header-remove-whitespace | |
276 (mail-header-remove-comments | |
277 cte))))) | |
278 no-strict-mime | |
279 (and cd (ignore-errors (mail-header-parse-content-disposition cd))) | |
280 description id)))) | |
281 (when id | |
282 (when (string-match " *<\\(.*\\)> *" id) | |
283 (setq id (match-string 1 id))) | |
284 (push (cons id result) mm-content-id-alist)) | |
285 result)))) | |
286 | |
287 (defun mm-dissect-singlepart (ctl cte &optional force cdl description id) | |
288 (when (or force | |
289 (if (equal "text/plain" (car ctl)) | |
290 (assoc 'format ctl) | |
291 t)) | |
292 (let ((res (mm-make-handle | |
293 (mm-copy-to-buffer) ctl cte nil cdl description nil id))) | |
294 (push (car res) mm-dissection-list) | |
295 res))) | |
296 | |
297 (defun mm-remove-all-parts () | |
298 "Remove all MIME handles." | |
299 (interactive) | |
300 (mapcar 'mm-remove-part mm-dissection-list) | |
301 (setq mm-dissection-list nil)) | |
302 | |
303 (defun mm-dissect-multipart (ctl) | |
304 (goto-char (point-min)) | |
305 (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary))) | |
306 (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$")) | |
307 start parts | |
308 (end (save-excursion | |
309 (goto-char (point-max)) | |
310 (if (re-search-backward close-delimiter nil t) | |
311 (match-beginning 0) | |
312 (point-max))))) | |
313 (setq boundary (concat (regexp-quote boundary) "[ \t]*$")) | |
314 (while (re-search-forward boundary end t) | |
315 (goto-char (match-beginning 0)) | |
316 (when start | |
317 (save-excursion | |
318 (save-restriction | |
319 (narrow-to-region start (point)) | |
320 (setq parts (nconc (list (mm-dissect-buffer t)) parts))))) | |
321 (forward-line 2) | |
322 (setq start (point))) | |
323 (when start | |
324 (save-excursion | |
325 (save-restriction | |
326 (narrow-to-region start end) | |
327 (setq parts (nconc (list (mm-dissect-buffer t)) parts))))) | |
328 (nreverse parts))) | |
329 | |
330 (defun mm-copy-to-buffer () | |
331 "Copy the contents of the current buffer to a fresh buffer." | |
332 (save-excursion | |
333 (let ((obuf (current-buffer)) | |
334 beg) | |
335 (goto-char (point-min)) | |
336 (search-forward-regexp "^\n" nil t) | |
337 (setq beg (point)) | |
338 (set-buffer (generate-new-buffer " *mm*")) | |
339 (insert-buffer-substring obuf beg) | |
340 (current-buffer)))) | |
341 | |
342 (defun mm-display-part (handle &optional no-default) | |
343 "Display the MIME part represented by HANDLE. | |
344 Returns nil if the part is removed; inline if displayed inline; | |
345 external if displayed external." | |
346 (save-excursion | |
347 (mailcap-parse-mailcaps) | |
348 (if (mm-handle-displayed-p handle) | |
349 (mm-remove-part handle) | |
350 (let* ((type (mm-handle-media-type handle)) | |
351 (method (mailcap-mime-info type))) | |
352 (if (mm-inlined-p handle) | |
353 (progn | |
354 (forward-line 1) | |
355 (mm-display-inline handle) | |
356 'inline) | |
357 (when (or method | |
358 (not no-default)) | |
359 (if (and (not method) | |
360 (equal "text" (car (split-string type)))) | |
361 (progn | |
362 (forward-line 1) | |
363 (mm-insert-inline handle (mm-get-part handle)) | |
364 'inline) | |
365 (mm-display-external | |
366 handle (or method 'mailcap-save-binary-file))))))))) | |
367 | |
368 (defun mm-display-external (handle method) | |
369 "Display HANDLE using METHOD." | |
370 (let ((outbuf (current-buffer))) | |
371 (mm-with-unibyte-buffer | |
372 (if (functionp method) | |
373 (let ((cur (current-buffer))) | |
374 (if (eq method 'mailcap-save-binary-file) | |
375 (progn | |
33174
702845b072b7
(mm-display-external): Space prefix temp buffer
Dave Love <fx@gnu.org>
parents:
32962
diff
changeset
|
376 (set-buffer (generate-new-buffer " *mm*")) |
31717 | 377 (setq method nil)) |
378 (mm-insert-part handle) | |
379 (let ((win (get-buffer-window cur t))) | |
380 (when win | |
381 (select-window win))) | |
33174
702845b072b7
(mm-display-external): Space prefix temp buffer
Dave Love <fx@gnu.org>
parents:
32962
diff
changeset
|
382 (switch-to-buffer (generate-new-buffer " *mm*"))) |
31717 | 383 (mm-set-buffer-file-coding-system mm-binary-coding-system) |
384 (insert-buffer-substring cur) | |
385 (goto-char (point-min)) | |
386 (message "Viewing with %s" method) | |
387 (let ((mm (current-buffer)) | |
388 (non-viewer (assq 'non-viewer | |
389 (mailcap-mime-info | |
390 (mm-handle-media-type handle) t)))) | |
391 (unwind-protect | |
392 (if method | |
393 (funcall method) | |
394 (mm-save-part handle)) | |
395 (when (and (not non-viewer) | |
396 method) | |
397 (mm-handle-set-undisplayer handle mm))))) | |
398 ;; The function is a string to be executed. | |
399 (mm-insert-part handle) | |
400 (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory))) | |
401 (filename (mail-content-type-get | |
402 (mm-handle-disposition handle) 'filename)) | |
403 (mime-info (mailcap-mime-info | |
404 (mm-handle-media-type handle) t)) | |
405 (needsterm (or (assoc "needsterm" mime-info) | |
406 (assoc "needsterminal" mime-info))) | |
407 (copiousoutput (assoc "copiousoutput" mime-info)) | |
408 file buffer) | |
409 ;; We create a private sub-directory where we store our files. | |
410 (make-directory dir) | |
411 (set-file-modes dir 448) | |
412 (if filename | |
413 (setq file (expand-file-name (file-name-nondirectory filename) | |
414 dir)) | |
415 (setq file (make-temp-name (expand-file-name "mm." dir)))) | |
416 (let ((coding-system-for-write mm-binary-coding-system)) | |
417 (write-region (point-min) (point-max) file nil 'nomesg)) | |
418 (message "Viewing with %s" method) | |
419 (cond (needsterm | |
420 (unwind-protect | |
421 (start-process "*display*" nil | |
422 "xterm" | |
423 "-e" shell-file-name | |
424 shell-command-switch | |
425 (mm-mailcap-command | |
426 method file (mm-handle-type handle))) | |
427 (mm-handle-set-undisplayer handle (cons file buffer))) | |
428 (message "Displaying %s..." (format method file)) | |
429 'external) | |
430 (copiousoutput | |
431 (with-current-buffer outbuf | |
432 (forward-line 1) | |
433 (mm-insert-inline | |
434 handle | |
435 (unwind-protect | |
436 (progn | |
437 (call-process shell-file-name nil | |
438 (setq buffer | |
439 (generate-new-buffer "*mm*")) | |
440 nil | |
441 shell-command-switch | |
442 (mm-mailcap-command | |
443 method file (mm-handle-type handle))) | |
444 (if (buffer-live-p buffer) | |
445 (save-excursion | |
446 (set-buffer buffer) | |
447 (buffer-string)))) | |
448 (progn | |
449 (ignore-errors (delete-file file)) | |
450 (ignore-errors (delete-directory | |
451 (file-name-directory file))) | |
452 (ignore-errors (kill-buffer buffer)))))) | |
453 'inline) | |
454 (t | |
455 (unwind-protect | |
456 (start-process "*display*" | |
457 (setq buffer | |
458 (generate-new-buffer "*mm*")) | |
459 shell-file-name | |
460 shell-command-switch | |
461 (mm-mailcap-command | |
462 method file (mm-handle-type handle))) | |
463 (mm-handle-set-undisplayer handle (cons file buffer))) | |
464 (message "Displaying %s..." (format method file)) | |
465 'external))))))) | |
466 | |
467 (defun mm-mailcap-command (method file type-list) | |
468 (let ((ctl (cdr type-list)) | |
469 (beg 0) | |
470 (uses-stdin t) | |
471 out sub total) | |
472 (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg) | |
473 (push (substring method beg (match-beginning 0)) out) | |
474 (setq beg (match-end 0) | |
475 total (match-string 0 method) | |
476 sub (match-string 1 method)) | |
477 (cond | |
478 ((string= total "%%") | |
479 (push "%" out)) | |
480 ((string= total "%s") | |
481 (setq uses-stdin nil) | |
482 (push (mm-quote-arg file) out)) | |
483 ((string= total "%t") | |
484 (push (mm-quote-arg (car type-list)) out)) | |
485 (t | |
486 (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out)))) | |
487 (push (substring method beg (length method)) out) | |
488 (if uses-stdin | |
489 (progn | |
490 (push "<" out) | |
491 (push (mm-quote-arg file) out))) | |
492 (mapconcat 'identity (nreverse out) ""))) | |
493 | |
494 (defun mm-remove-parts (handles) | |
495 "Remove the displayed MIME parts represented by HANDLES." | |
496 (if (and (listp handles) | |
497 (bufferp (car handles))) | |
498 (mm-remove-part handles) | |
499 (let (handle) | |
500 (while (setq handle (pop handles)) | |
501 (cond | |
502 ((stringp handle) | |
503 ;; Do nothing. | |
504 ) | |
505 ((and (listp handle) | |
506 (stringp (car handle))) | |
507 (mm-remove-parts (cdr handle))) | |
508 (t | |
509 (mm-remove-part handle))))))) | |
510 | |
511 (defun mm-destroy-parts (handles) | |
512 "Remove the displayed MIME parts represented by HANDLES." | |
513 (if (and (listp handles) | |
514 (bufferp (car handles))) | |
515 (mm-destroy-part handles) | |
516 (let (handle) | |
517 (while (setq handle (pop handles)) | |
518 (cond | |
519 ((stringp handle) | |
520 ;; Do nothing. | |
521 ) | |
522 ((and (listp handle) | |
523 (stringp (car handle))) | |
524 (mm-destroy-parts (cdr handle))) | |
525 (t | |
526 (mm-destroy-part handle))))))) | |
527 | |
528 (defun mm-remove-part (handle) | |
529 "Remove the displayed MIME part represented by HANDLE." | |
530 (when (listp handle) | |
531 (let ((object (mm-handle-undisplayer handle))) | |
532 (ignore-errors | |
533 (cond | |
534 ;; Internally displayed part. | |
535 ((mm-annotationp object) | |
536 (delete-annotation object)) | |
537 ((or (functionp object) | |
538 (and (listp object) | |
539 (eq (car object) 'lambda))) | |
540 (funcall object)) | |
541 ;; Externally displayed part. | |
542 ((consp object) | |
543 (ignore-errors (delete-file (car object))) | |
544 (ignore-errors (delete-directory (file-name-directory (car object)))) | |
545 (ignore-errors (kill-buffer (cdr object)))) | |
546 ((bufferp object) | |
547 (when (buffer-live-p object) | |
548 (kill-buffer object))))) | |
549 (mm-handle-set-undisplayer handle nil)))) | |
550 | |
551 (defun mm-display-inline (handle) | |
552 (let* ((type (mm-handle-media-type handle)) | |
553 (function (cadr (mm-assoc-string-match mm-inline-media-tests type)))) | |
554 (funcall function handle) | |
555 (goto-char (point-min)))) | |
556 | |
557 (defun mm-assoc-string-match (alist type) | |
558 (dolist (elem alist) | |
559 (when (string-match (car elem) type) | |
560 (return elem)))) | |
561 | |
562 (defun mm-inlinable-p (handle) | |
563 "Say whether HANDLE can be displayed inline." | |
564 (let ((alist mm-inline-media-tests) | |
565 (type (mm-handle-media-type handle)) | |
566 test) | |
567 (while alist | |
568 (when (string-match (caar alist) type) | |
569 (setq test (caddar alist) | |
570 alist nil) | |
571 (setq test (funcall test handle))) | |
572 (pop alist)) | |
573 test)) | |
574 | |
575 (defun mm-automatic-display-p (handle) | |
576 "Say whether the user wants HANDLE to be displayed automatically." | |
577 (let ((methods mm-automatic-display) | |
578 (type (mm-handle-media-type handle)) | |
579 method result) | |
580 (while (setq method (pop methods)) | |
581 (when (and (not (mm-inline-override-p handle)) | |
582 (string-match method type) | |
583 (mm-inlinable-p handle)) | |
584 (setq result t | |
585 methods nil))) | |
586 result)) | |
587 | |
588 (defun mm-inlined-p (handle) | |
589 "Say whether the user wants HANDLE to be displayed automatically." | |
590 (let ((methods mm-inlined-types) | |
591 (type (mm-handle-media-type handle)) | |
592 method result) | |
593 (while (setq method (pop methods)) | |
594 (when (and (not (mm-inline-override-p handle)) | |
595 (string-match method type) | |
596 (mm-inlinable-p handle)) | |
597 (setq result t | |
598 methods nil))) | |
599 result)) | |
600 | |
601 (defun mm-attachment-override-p (handle) | |
602 "Say whether HANDLE should have attachment behavior overridden." | |
603 (let ((types mm-attachment-override-types) | |
604 (type (mm-handle-media-type handle)) | |
605 ty) | |
606 (catch 'found | |
607 (while (setq ty (pop types)) | |
608 (when (and (string-match ty type) | |
609 (mm-inlinable-p handle)) | |
610 (throw 'found t)))))) | |
611 | |
612 (defun mm-inline-override-p (handle) | |
613 "Say whether HANDLE should have inline behavior overridden." | |
614 (let ((types mm-inline-override-types) | |
615 (type (mm-handle-media-type handle)) | |
616 ty) | |
617 (catch 'found | |
618 (while (setq ty (pop types)) | |
619 (when (string-match ty type) | |
620 (throw 'found t)))))) | |
621 | |
622 (defun mm-automatic-external-display-p (type) | |
623 "Return the user-defined method for TYPE." | |
624 (let ((methods mm-automatic-external-display) | |
625 method result) | |
626 (while (setq method (pop methods)) | |
627 (when (string-match method type) | |
628 (setq result t | |
629 methods nil))) | |
630 result)) | |
631 | |
632 (defun mm-destroy-part (handle) | |
633 "Destroy the data structures connected to HANDLE." | |
634 (when (listp handle) | |
635 (mm-remove-part handle) | |
636 (when (buffer-live-p (mm-handle-buffer handle)) | |
637 (kill-buffer (mm-handle-buffer handle))))) | |
638 | |
639 (defun mm-handle-displayed-p (handle) | |
640 "Say whether HANDLE is displayed or not." | |
641 (mm-handle-undisplayer handle)) | |
642 | |
643 ;;; | |
644 ;;; Functions for outputting parts | |
645 ;;; | |
646 | |
647 (defun mm-get-part (handle) | |
648 "Return the contents of HANDLE as a string." | |
649 (mm-with-unibyte-buffer | |
650 (mm-insert-part handle) | |
651 (buffer-string))) | |
652 | |
653 (defun mm-insert-part (handle) | |
654 "Insert the contents of HANDLE in the current buffer." | |
655 (let ((cur (current-buffer))) | |
656 (save-excursion | |
657 (if (member (mm-handle-media-supertype handle) '("text" "message")) | |
658 (with-temp-buffer | |
659 (insert-buffer-substring (mm-handle-buffer handle)) | |
660 (mm-decode-content-transfer-encoding | |
661 (mm-handle-encoding handle) | |
662 (mm-handle-media-type handle)) | |
663 (let ((temp (current-buffer))) | |
664 (set-buffer cur) | |
665 (insert-buffer-substring temp))) | |
666 (mm-with-unibyte-buffer | |
667 (insert-buffer-substring (mm-handle-buffer handle)) | |
668 (mm-decode-content-transfer-encoding | |
669 (mm-handle-encoding handle) | |
670 (mm-handle-media-type handle)) | |
671 (let ((temp (current-buffer))) | |
672 (set-buffer cur) | |
673 (insert-buffer-substring temp))))))) | |
674 | |
675 (defvar mm-default-directory nil) | |
676 | |
677 (defun mm-save-part (handle) | |
678 "Write HANDLE to a file." | |
679 (let* ((name (mail-content-type-get (mm-handle-type handle) 'name)) | |
680 (filename (mail-content-type-get | |
681 (mm-handle-disposition handle) 'filename)) | |
682 file) | |
683 (when filename | |
684 (setq filename (file-name-nondirectory filename))) | |
685 (setq file | |
686 (read-file-name "Save MIME part to: " | |
687 (expand-file-name | |
688 (or filename name "") | |
689 (or mm-default-directory default-directory)))) | |
690 (setq mm-default-directory (file-name-directory file)) | |
691 (when (or (not (file-exists-p file)) | |
692 (yes-or-no-p (format "File %s already exists; overwrite? " | |
693 file))) | |
694 (mm-save-part-to-file handle file)))) | |
695 | |
696 (defun mm-save-part-to-file (handle file) | |
697 (mm-with-unibyte-buffer | |
698 (mm-insert-part handle) | |
699 (let ((coding-system-for-write 'binary) | |
700 ;; Don't re-compress .gz & al. Arguably we should make | |
701 ;; `file-name-handler-alist' nil, but that would chop | |
702 ;; ange-ftp, which is reasonable to use here. | |
703 (inhibit-file-name-operation 'write-region) | |
704 (inhibit-file-name-handlers | |
705 (cons 'jka-compr-handler inhibit-file-name-handlers))) | |
706 (write-region (point-min) (point-max) file)))) | |
707 | |
708 (defun mm-pipe-part (handle) | |
709 "Pipe HANDLE to a process." | |
710 (let* ((name (mail-content-type-get (mm-handle-type handle) 'name)) | |
711 (command | |
712 (read-string "Shell command on MIME part: " mm-last-shell-command))) | |
713 (mm-with-unibyte-buffer | |
714 (mm-insert-part handle) | |
715 (shell-command-on-region (point-min) (point-max) command nil)))) | |
716 | |
717 (defun mm-interactively-view-part (handle) | |
718 "Display HANDLE using METHOD." | |
719 (let* ((type (mm-handle-media-type handle)) | |
720 (methods | |
721 (mapcar (lambda (i) (list (cdr (assoc 'viewer i)))) | |
722 (mailcap-mime-info type 'all))) | |
32962 | 723 (method (let ((minibuffer-local-completion-map |
724 mm-viewer-completion-map)) | |
725 (completing-read "Viewer: " methods)))) | |
31717 | 726 (when (string= method "") |
727 (error "No method given")) | |
728 (if (string-match "^[^% \t]+$" method) | |
729 (setq method (concat method " %s"))) | |
730 (mm-display-external (copy-sequence handle) method))) | |
731 | |
732 (defun mm-preferred-alternative (handles &optional preferred) | |
733 "Say which of HANDLES are preferred." | |
734 (let ((prec (if preferred (list preferred) | |
735 (mm-preferred-alternative-precedence handles))) | |
736 p h result type handle) | |
737 (while (setq p (pop prec)) | |
738 (setq h handles) | |
739 (while h | |
740 (setq handle (car h)) | |
741 (setq type (mm-handle-media-type handle)) | |
742 (when (and (equal p type) | |
743 (mm-automatic-display-p handle) | |
744 (or (stringp (car handle)) | |
745 (not (mm-handle-disposition handle)) | |
746 (equal (car (mm-handle-disposition handle)) | |
747 "inline"))) | |
748 (setq result handle | |
749 h nil | |
750 prec nil)) | |
751 (pop h))) | |
752 result)) | |
753 | |
754 (defun mm-preferred-alternative-precedence (handles) | |
755 "Return the precedence based on HANDLES and `mm-discouraged-alternatives'." | |
756 (let ((seq (nreverse (mapcar #'mm-handle-media-type | |
757 handles)))) | |
758 (dolist (disc (reverse mm-discouraged-alternatives)) | |
759 (dolist (elem (copy-sequence seq)) | |
760 (when (string-match disc elem) | |
761 (setq seq (nconc (delete elem seq) (list elem)))))) | |
762 seq)) | |
763 | |
764 (defun mm-get-content-id (id) | |
765 "Return the handle(s) referred to by ID." | |
766 (cdr (assoc id mm-content-id-alist))) | |
767 | |
768 (defun mm-get-image (handle) | |
769 "Return an image instance based on HANDLE." | |
770 (let ((type (mm-handle-media-subtype handle)) | |
771 spec) | |
772 ;; Allow some common translations. | |
773 (setq type | |
774 (cond | |
775 ((equal type "x-pixmap") | |
776 "xpm") | |
777 ((equal type "x-xbitmap") | |
778 "xbm") | |
779 (t type))) | |
780 (or (mm-handle-cache handle) | |
781 (mm-with-unibyte-buffer | |
782 (mm-insert-part handle) | |
783 (prog1 | |
784 (setq spec | |
785 (ignore-errors | |
786 ;; Avoid testing `make-glyph' since W3 may define | |
787 ;; a bogus version of it. | |
788 (if (fboundp 'create-image) | |
789 (create-image (buffer-string) (intern type) 'data-p) | |
790 (cond | |
791 ((equal type "xbm") | |
792 ;; xbm images require special handling, since | |
793 ;; the only way to create glyphs from these | |
794 ;; (without a ton of work) is to write them | |
795 ;; out to a file, and then create a file | |
796 ;; specifier. | |
797 (let ((file (make-temp-name | |
798 (expand-file-name "emm.xbm" | |
799 mm-tmp-directory)))) | |
800 (unwind-protect | |
801 (progn | |
802 (write-region (point-min) (point-max) file) | |
803 (make-glyph (list (cons 'x file)))) | |
804 (ignore-errors | |
805 (delete-file file))))) | |
806 (t | |
807 (make-glyph | |
808 (vector (intern type) :data (buffer-string)))))))) | |
809 (mm-handle-set-cache handle spec)))))) | |
810 | |
811 (defun mm-image-fit-p (handle) | |
812 "Say whether the image in HANDLE will fit the current window." | |
813 (let ((image (mm-get-image handle))) | |
814 (if (fboundp 'glyph-width) | |
815 ;; XEmacs' glyphs can actually tell us about their width, so | |
816 ;; lets be nice and smart about them. | |
817 (or mm-inline-large-images | |
818 (and (< (glyph-width image) (window-pixel-width)) | |
819 (< (glyph-height image) (window-pixel-height)))) | |
820 (let* ((size (image-size image)) | |
821 (w (car size)) | |
822 (h (cdr size))) | |
823 (or mm-inline-large-images | |
824 (and (< h (1- (window-height))) ; Don't include mode line. | |
825 (< w (window-width)))))))) | |
826 | |
827 (defun mm-valid-image-format-p (format) | |
828 "Say whether FORMAT can be displayed natively by Emacs." | |
829 (cond | |
830 ;; Handle XEmacs | |
831 ((fboundp 'valid-image-instantiator-format-p) | |
832 (valid-image-instantiator-format-p format)) | |
833 ;; Handle Emacs 21 | |
834 ((fboundp 'image-type-available-p) | |
835 (and (display-graphic-p) | |
836 (image-type-available-p format))) | |
837 ;; Nobody else can do images yet. | |
838 (t | |
839 nil))) | |
840 | |
841 (defun mm-valid-and-fit-image-p (format handle) | |
842 "Say whether FORMAT can be displayed natively and HANDLE fits the window." | |
32962 | 843 (and (mm-valid-image-format-p format) |
31717 | 844 (mm-image-fit-p handle))) |
845 | |
846 (provide 'mm-decode) | |
847 | |
848 ;;; mm-decode.el ends here |