]> code.delx.au - gnu-emacs/blob - lisp/gnus/mm-view.el
735cc2569c3fe0ed87348e67fd66edbdf8f19ba1
[gnu-emacs] / lisp / gnus / mm-view.el
1 ;;; mm-view.el --- functions for viewing MIME objects
2
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005 Free Software Foundation, Inc.
5
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
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., 51 Franklin Street, Fifth Floor,
22 ;; Boston, MA 02110-1301, USA.
23
24 ;;; Commentary:
25
26 ;;; Code:
27
28 (eval-when-compile (require 'cl))
29 (require 'mail-parse)
30 (require 'mailcap)
31 (require 'mm-bodies)
32 (require 'mm-decode)
33
34 (eval-and-compile
35 (autoload 'gnus-article-prepare-display "gnus-art")
36 (autoload 'vcard-parse-string "vcard")
37 (autoload 'vcard-format-string "vcard")
38 (autoload 'fill-flowed "flow-fill")
39 (autoload 'html2text "html2text")
40 (unless (fboundp 'diff-mode)
41 (autoload 'diff-mode "diff-mode" "" t nil)))
42
43 (defvar mm-text-html-renderer-alist
44 '((w3 . mm-inline-text-html-render-with-w3)
45 (w3m . mm-inline-text-html-render-with-w3m)
46 (w3m-standalone mm-inline-render-with-stdin nil
47 "w3m" "-dump" "-T" "text/html")
48 (links mm-inline-render-with-file
49 mm-links-remove-leading-blank
50 "links" "-dump" file)
51 (lynx mm-inline-render-with-stdin nil
52 "lynx" "-dump" "-force_html" "-stdin" "-nolist")
53 (html2text mm-inline-render-with-function html2text))
54 "The attributes of renderer types for text/html.")
55
56 (defvar mm-text-html-washer-alist
57 '((w3 . gnus-article-wash-html-with-w3)
58 (w3m . gnus-article-wash-html-with-w3m)
59 (w3m-standalone mm-inline-wash-with-stdin nil
60 "w3m" "-dump" "-T" "text/html")
61 (links mm-inline-wash-with-file
62 mm-links-remove-leading-blank
63 "links" "-dump" file)
64 (lynx mm-inline-wash-with-stdin nil
65 "lynx" "-dump" "-force_html" "-stdin" "-nolist")
66 (html2text html2text))
67 "The attributes of washer types for text/html.")
68
69 ;;; Internal variables.
70
71 ;;;
72 ;;; Functions for displaying various formats inline
73 ;;;
74
75 (defun mm-inline-image-emacs (handle)
76 (let ((b (point-marker))
77 buffer-read-only)
78 (put-image (mm-get-image handle) b)
79 (insert "\n\n")
80 (mm-handle-set-undisplayer
81 handle
82 `(lambda ()
83 (let ((b ,b)
84 buffer-read-only)
85 (remove-images b b)
86 (delete-region b (+ b 2)))))))
87
88 (defun mm-inline-image-xemacs (handle)
89 (insert "\n\n")
90 (forward-char -2)
91 (let ((annot (make-annotation (mm-get-image handle) nil 'text))
92 buffer-read-only)
93 (mm-handle-set-undisplayer
94 handle
95 `(lambda ()
96 (let ((b ,(point-marker))
97 buffer-read-only)
98 (delete-annotation ,annot)
99 (delete-region (- b 2) b))))
100 (set-extent-property annot 'mm t)
101 (set-extent-property annot 'duplicable t)))
102
103 (eval-and-compile
104 (if (featurep 'xemacs)
105 (defalias 'mm-inline-image 'mm-inline-image-xemacs)
106 (defalias 'mm-inline-image 'mm-inline-image-emacs)))
107
108 (defvar mm-w3-setup nil)
109 (defun mm-setup-w3 ()
110 (unless mm-w3-setup
111 (require 'w3)
112 (w3-do-setup)
113 (require 'url)
114 (require 'w3-vars)
115 (require 'url-vars)
116 (setq mm-w3-setup t)))
117
118 (defun mm-inline-text-html-render-with-w3 (handle)
119 (mm-setup-w3)
120 (let ((text (mm-get-part handle))
121 (b (point))
122 (url-standalone-mode t)
123 (url-gateway-unplugged t)
124 (w3-honor-stylesheets nil)
125 (url-current-object
126 (url-generic-parse-url (format "cid:%s" (mm-handle-id handle))))
127 (width (window-width))
128 (charset (mail-content-type-get
129 (mm-handle-type handle) 'charset)))
130 (save-excursion
131 (insert text)
132 (save-restriction
133 (narrow-to-region b (point))
134 (goto-char (point-min))
135 (if (or (and (boundp 'w3-meta-content-type-charset-regexp)
136 (re-search-forward
137 w3-meta-content-type-charset-regexp nil t))
138 (and (boundp 'w3-meta-charset-content-type-regexp)
139 (re-search-forward
140 w3-meta-charset-content-type-regexp nil t)))
141 (setq charset
142 (or (let ((bsubstr (buffer-substring-no-properties
143 (match-beginning 2)
144 (match-end 2))))
145 (if (fboundp 'w3-coding-system-for-mime-charset)
146 (w3-coding-system-for-mime-charset bsubstr)
147 (mm-charset-to-coding-system bsubstr)))
148 charset)))
149 (delete-region (point-min) (point-max))
150 (insert (mm-decode-string text charset))
151 (save-window-excursion
152 (save-restriction
153 (let ((w3-strict-width width)
154 ;; Don't let w3 set the global version of
155 ;; this variable.
156 (fill-column fill-column))
157 (if (or debug-on-error debug-on-quit)
158 (w3-region (point-min) (point-max))
159 (condition-case ()
160 (w3-region (point-min) (point-max))
161 (error
162 (delete-region (point-min) (point-max))
163 (let ((b (point))
164 (charset (mail-content-type-get
165 (mm-handle-type handle) 'charset)))
166 (if (or (eq charset 'gnus-decoded)
167 (eq mail-parse-charset 'gnus-decoded))
168 (save-restriction
169 (narrow-to-region (point) (point))
170 (mm-insert-part handle)
171 (goto-char (point-max)))
172 (insert (mm-decode-string (mm-get-part handle)
173 charset))))
174 (message
175 "Error while rendering html; showing as text/plain")))))))
176 (mm-handle-set-undisplayer
177 handle
178 `(lambda ()
179 (let (buffer-read-only)
180 (if (functionp 'remove-specifier)
181 (mapcar (lambda (prop)
182 (remove-specifier
183 (face-property 'default prop)
184 (current-buffer)))
185 '(background background-pixmap foreground)))
186 (delete-region ,(point-min-marker)
187 ,(point-max-marker)))))))))
188
189 (defvar mm-w3m-setup nil
190 "Whether gnus-article-mode has been setup to use emacs-w3m.")
191
192 (defun mm-setup-w3m ()
193 "Setup gnus-article-mode to use emacs-w3m."
194 (unless mm-w3m-setup
195 (require 'w3m)
196 (unless (assq 'gnus-article-mode w3m-cid-retrieve-function-alist)
197 (push (cons 'gnus-article-mode 'mm-w3m-cid-retrieve)
198 w3m-cid-retrieve-function-alist))
199 (setq mm-w3m-setup t))
200 (setq w3m-display-inline-images mm-inline-text-html-with-images))
201
202 (defun mm-w3m-cid-retrieve-1 (url handle)
203 (dolist (elem handle)
204 (when (listp elem)
205 (if (equal url (mm-handle-id elem))
206 (progn
207 (mm-insert-part elem)
208 (throw 'found-handle (mm-handle-media-type elem))))
209 (if (equal "multipart" (mm-handle-media-supertype elem))
210 (mm-w3m-cid-retrieve-1 url elem)))))
211
212 (defun mm-w3m-cid-retrieve (url &rest args)
213 "Insert a content pointed by URL if it has the cid: scheme."
214 (when (string-match "\\`cid:" url)
215 (catch 'found-handle
216 (mm-w3m-cid-retrieve-1 (concat "<" (substring url (match-end 0)) ">")
217 (with-current-buffer w3m-current-buffer
218 gnus-article-mime-handles)))))
219
220 (defun mm-inline-text-html-render-with-w3m (handle)
221 "Render a text/html part using emacs-w3m."
222 (mm-setup-w3m)
223 (let ((text (mm-get-part handle))
224 (b (point))
225 (charset (mail-content-type-get (mm-handle-type handle) 'charset)))
226 (save-excursion
227 (insert (if charset (mm-decode-string text charset) text))
228 (save-restriction
229 (narrow-to-region b (point))
230 (unless charset
231 (goto-char (point-min))
232 (when (setq charset (w3m-detect-meta-charset))
233 (delete-region (point-min) (point-max))
234 (insert (mm-decode-string text charset))))
235 (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
236 w3m-force-redisplay)
237 (w3m-region (point-min) (point-max) nil charset))
238 (when (and mm-inline-text-html-with-w3m-keymap
239 (boundp 'w3m-minor-mode-map)
240 w3m-minor-mode-map)
241 (add-text-properties
242 (point-min) (point-max)
243 (list 'keymap w3m-minor-mode-map
244 ;; Put the mark meaning this part was rendered by emacs-w3m.
245 'mm-inline-text-html-with-w3m t))))
246 (mm-handle-set-undisplayer
247 handle
248 `(lambda ()
249 (let (buffer-read-only)
250 (if (functionp 'remove-specifier)
251 (mapcar (lambda (prop)
252 (remove-specifier
253 (face-property 'default prop)
254 (current-buffer)))
255 '(background background-pixmap foreground)))
256 (delete-region ,(point-min-marker)
257 ,(point-max-marker))))))))
258
259 (defun mm-links-remove-leading-blank ()
260 ;; Delete the annoying three spaces preceding each line of links
261 ;; output.
262 (goto-char (point-min))
263 (while (re-search-forward "^ " nil t)
264 (delete-region (match-beginning 0) (match-end 0))))
265
266 (defun mm-inline-wash-with-file (post-func cmd &rest args)
267 (let ((file (mm-make-temp-file
268 (expand-file-name "mm" mm-tmp-directory))))
269 (let ((coding-system-for-write 'binary))
270 (write-region (point-min) (point-max) file nil 'silent))
271 (delete-region (point-min) (point-max))
272 (unwind-protect
273 (apply 'call-process cmd nil t nil (mapcar 'eval args))
274 (delete-file file))
275 (and post-func (funcall post-func))))
276
277 (defun mm-inline-wash-with-stdin (post-func cmd &rest args)
278 (let ((coding-system-for-write 'binary))
279 (apply 'call-process-region (point-min) (point-max)
280 cmd t t nil args))
281 (and post-func (funcall post-func)))
282
283 (defun mm-inline-render-with-file (handle post-func cmd &rest args)
284 (let ((source (mm-get-part handle)))
285 (mm-insert-inline
286 handle
287 (mm-with-unibyte-buffer
288 (insert source)
289 (apply 'mm-inline-wash-with-file post-func cmd args)
290 (buffer-string)))))
291
292 (defun mm-inline-render-with-stdin (handle post-func cmd &rest args)
293 (let ((source (mm-get-part handle)))
294 (mm-insert-inline
295 handle
296 (mm-with-unibyte-buffer
297 (insert source)
298 (apply 'mm-inline-wash-with-stdin post-func cmd args)
299 (buffer-string)))))
300
301 (defun mm-inline-render-with-function (handle func &rest args)
302 (let ((source (mm-get-part handle))
303 (charset (mail-content-type-get (mm-handle-type handle) 'charset)))
304 (mm-insert-inline
305 handle
306 (mm-with-multibyte-buffer
307 (insert (if charset
308 (mm-decode-string source charset)
309 source))
310 (apply func args)
311 (buffer-string)))))
312
313 (defun mm-inline-text-html (handle)
314 (let* ((func (or mm-inline-text-html-renderer mm-text-html-renderer))
315 (entry (assq func mm-text-html-renderer-alist))
316 buffer-read-only)
317 (if entry
318 (setq func (cdr entry)))
319 (cond
320 ((functionp func)
321 (funcall func handle))
322 (t
323 (apply (car func) handle (cdr func))))))
324
325 (defun mm-inline-text-vcard (handle)
326 (let (buffer-read-only)
327 (mm-insert-inline
328 handle
329 (concat "\n-- \n"
330 (ignore-errors
331 (if (fboundp 'vcard-pretty-print)
332 (vcard-pretty-print (mm-get-part handle))
333 (vcard-format-string
334 (vcard-parse-string (mm-get-part handle)
335 'vcard-standard-filter))))))))
336
337 (defun mm-inline-text (handle)
338 (let ((b (point))
339 (type (mm-handle-media-subtype handle))
340 (charset (mail-content-type-get
341 (mm-handle-type handle) 'charset))
342 buffer-read-only)
343 (if (or (eq charset 'gnus-decoded)
344 ;; This is probably not entirely correct, but
345 ;; makes rfc822 parts with embedded multiparts work.
346 (eq mail-parse-charset 'gnus-decoded))
347 (save-restriction
348 (narrow-to-region (point) (point))
349 (mm-insert-part handle)
350 (goto-char (point-max)))
351 (insert (mm-decode-string (mm-get-part handle) charset)))
352 (when (and (equal type "plain")
353 (equal (cdr (assoc 'format (mm-handle-type handle)))
354 "flowed"))
355 (save-restriction
356 (narrow-to-region b (point))
357 (goto-char b)
358 (fill-flowed)
359 (goto-char (point-max))))
360 (save-restriction
361 (narrow-to-region b (point))
362 (set-text-properties (point-min) (point-max) nil)
363 (when (or (equal type "enriched")
364 (equal type "richtext"))
365 (ignore-errors
366 (enriched-decode (point-min) (point-max))))
367 (mm-handle-set-undisplayer
368 handle
369 `(lambda ()
370 (let (buffer-read-only)
371 (delete-region ,(point-min-marker)
372 ,(point-max-marker))))))))
373
374 (defun mm-insert-inline (handle text)
375 "Insert TEXT inline from HANDLE."
376 (let ((b (point)))
377 (insert text)
378 (mm-handle-set-undisplayer
379 handle
380 `(lambda ()
381 (let (buffer-read-only)
382 (delete-region ,(set-marker (make-marker) b)
383 ,(set-marker (make-marker) (point))))))))
384
385 (defun mm-inline-audio (handle)
386 (message "Not implemented"))
387
388 (defun mm-view-sound-file ()
389 (message "Not implemented"))
390
391 (defun mm-w3-prepare-buffer ()
392 (require 'w3)
393 (let ((url-standalone-mode t)
394 (url-gateway-unplugged t)
395 (w3-honor-stylesheets nil))
396 (w3-prepare-buffer)))
397
398 (defun mm-view-message ()
399 (mm-enable-multibyte)
400 (let (handles)
401 (let (gnus-article-mime-handles)
402 ;; Double decode problem may happen. See mm-inline-message.
403 (run-hooks 'gnus-article-decode-hook)
404 (gnus-article-prepare-display)
405 (setq handles gnus-article-mime-handles))
406 (when handles
407 (setq gnus-article-mime-handles
408 (mm-merge-handles gnus-article-mime-handles handles))))
409 (fundamental-mode)
410 (goto-char (point-min)))
411
412 (defun mm-inline-message (handle)
413 (let ((b (point))
414 (bolp (bolp))
415 (charset (mail-content-type-get
416 (mm-handle-type handle) 'charset))
417 gnus-displaying-mime handles)
418 (when (and charset
419 (stringp charset))
420 (setq charset (intern (downcase charset)))
421 (when (eq charset 'us-ascii)
422 (setq charset nil)))
423 (save-excursion
424 (save-restriction
425 (narrow-to-region b b)
426 (mm-insert-part handle)
427 (let (gnus-article-mime-handles
428 ;; disable prepare hook
429 gnus-article-prepare-hook
430 (gnus-newsgroup-charset
431 (or charset gnus-newsgroup-charset)))
432 (let ((gnus-original-article-buffer (mm-handle-buffer handle)))
433 (run-hooks 'gnus-article-decode-hook))
434 (gnus-article-prepare-display)
435 (setq handles gnus-article-mime-handles))
436 (goto-char (point-min))
437 (unless bolp
438 (insert "\n"))
439 (goto-char (point-max))
440 (unless (bolp)
441 (insert "\n"))
442 (insert "----------\n\n")
443 (when handles
444 (setq gnus-article-mime-handles
445 (mm-merge-handles gnus-article-mime-handles handles)))
446 (mm-handle-set-undisplayer
447 handle
448 `(lambda ()
449 (let (buffer-read-only)
450 (if (fboundp 'remove-specifier)
451 ;; This is only valid on XEmacs.
452 (mapcar (lambda (prop)
453 (remove-specifier
454 (face-property 'default prop) (current-buffer)))
455 '(background background-pixmap foreground)))
456 (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
457
458 (defun mm-display-inline-fontify (handle mode)
459 (let (text)
460 ;; XEmacs @#$@ version of font-lock refuses to fully turn itself
461 ;; on for buffers whose name begins with " ". That's why we use
462 ;; save-current-buffer/get-buffer-create rather than
463 ;; with-temp-buffer.
464 (save-current-buffer
465 (set-buffer (generate-new-buffer "*fontification*"))
466 (unwind-protect
467 (progn
468 (buffer-disable-undo)
469 (mm-insert-part handle)
470 (require 'font-lock)
471 ;; Inhibit font-lock this time (*-mode-hook might run
472 ;; `turn-on-font-lock') so that jit-lock may not turn off
473 ;; font-lock immediately after this.
474 (let ((font-lock-mode t))
475 (funcall mode))
476 (let ((font-lock-verbose nil))
477 ;; I find font-lock a bit too verbose.
478 (font-lock-fontify-buffer))
479 ;; By default, XEmacs font-lock uses non-duplicable text
480 ;; properties. This code forces all the text properties
481 ;; to be copied along with the text.
482 (when (fboundp 'extent-list)
483 (map-extents (lambda (ext ignored)
484 (set-extent-property ext 'duplicable t)
485 nil)
486 nil nil nil nil nil 'text-prop))
487 (setq text (buffer-string)))
488 (kill-buffer (current-buffer))))
489 (mm-insert-inline handle text)))
490
491 ;; Shouldn't these functions check whether the user even wants to use
492 ;; font-lock? At least under XEmacs, this fontification is pretty
493 ;; much unconditional. Also, it would be nice to change for the size
494 ;; of the fontified region.
495
496 (defun mm-display-patch-inline (handle)
497 (mm-display-inline-fontify handle 'diff-mode))
498
499 (defun mm-display-elisp-inline (handle)
500 (mm-display-inline-fontify handle 'emacs-lisp-mode))
501
502 ;; id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
503 ;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 }
504 (defvar mm-pkcs7-signed-magic
505 (mm-string-as-unibyte
506 (apply 'concat
507 (mapcar 'char-to-string
508 (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c
509 ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e
510 ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48
511 ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x02)))))
512
513 ;; id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
514 ;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 }
515 (defvar mm-pkcs7-enveloped-magic
516 (mm-string-as-unibyte
517 (apply 'concat
518 (mapcar 'char-to-string
519 (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c
520 ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e
521 ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48
522 ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x03)))))
523
524 (defun mm-view-pkcs7-get-type (handle)
525 (mm-with-unibyte-buffer
526 (mm-insert-part handle)
527 (cond ((looking-at mm-pkcs7-enveloped-magic)
528 'enveloped)
529 ((looking-at mm-pkcs7-signed-magic)
530 'signed)
531 (t
532 (error "Could not identify PKCS#7 type")))))
533
534 (defun mm-view-pkcs7 (handle)
535 (case (mm-view-pkcs7-get-type handle)
536 (enveloped (mm-view-pkcs7-decrypt handle))
537 (signed (mm-view-pkcs7-verify handle))
538 (otherwise (error "Unknown or unimplemented PKCS#7 type"))))
539
540 (defun mm-view-pkcs7-verify (handle)
541 ;; A bogus implementation of PKCS#7. FIXME::
542 (mm-insert-part handle)
543 (goto-char (point-min))
544 (if (search-forward "Content-Type: " nil t)
545 (delete-region (point-min) (match-beginning 0)))
546 (goto-char (point-max))
547 (if (re-search-backward "--\r?\n?" nil t)
548 (delete-region (match-end 0) (point-max)))
549 (goto-char (point-min))
550 (while (search-forward "\r\n" nil t)
551 (replace-match "\n"))
552 (message "Verify signed PKCS#7 message is unimplemented.")
553 (sit-for 1)
554 t)
555
556 (autoload 'gnus-completing-read-maybe-default "gnus-util" nil nil 'macro)
557
558 (defun mm-view-pkcs7-decrypt (handle)
559 (insert-buffer-substring (mm-handle-buffer handle))
560 (goto-char (point-min))
561 (insert "MIME-Version: 1.0\n")
562 (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m")
563 (smime-decrypt-region
564 (point-min) (point-max)
565 (if (= (length smime-keys) 1)
566 (cadar smime-keys)
567 (smime-get-key-by-email
568 (gnus-completing-read-maybe-default
569 (concat "Decipher using which key? "
570 (if smime-keys (concat "(default " (caar smime-keys) ") ")
571 ""))
572 smime-keys nil nil nil nil (car-safe (car-safe smime-keys))))))
573 (goto-char (point-min))
574 (while (search-forward "\r\n" nil t)
575 (replace-match "\n"))
576 (goto-char (point-min)))
577
578 (provide 'mm-view)
579
580 ;;; arch-tag: b60e749a-d05c-47f2-bccd-bdaa59327cb2
581 ;;; mm-view.el ends here