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