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