Remove msword code. mailcap is good enough.
[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 for text/html.")
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 for text/html.")
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     (let ((coding-system-for-write 'binary))
315       (write-region (point-min) (point-max) file nil 'silent))
316     (delete-region (point-min) (point-max))
317     (unwind-protect
318         (apply 'call-process cmd nil t nil (mapcar 'eval args))
319       (delete-file file))
320     (and post-func (funcall post-func))))
321
322 (defun mm-inline-wash-with-stdin (post-func cmd &rest args)
323   (let ((coding-system-for-write 'binary))
324     (apply 'call-process-region (point-min) (point-max)
325            cmd t t nil args))
326   (and post-func (funcall post-func)))
327
328 (defun mm-inline-render-with-file (handle post-func cmd &rest args)
329   (let ((source (mm-get-part handle)))
330     (mm-insert-inline
331      handle
332      (mm-with-unibyte-buffer
333        (insert source)
334        (apply 'mm-inline-wash-with-file post-func cmd args)
335        (buffer-string)))))
336
337 (defun mm-inline-render-with-stdin (handle post-func cmd &rest args)
338   (let ((source (mm-get-part handle)))
339     (mm-insert-inline 
340      handle 
341      (mm-with-unibyte-buffer
342        (insert source)
343        (apply 'mm-inline-wash-with-stdin post-func cmd args)
344        (buffer-string)))))
345
346 (defun mm-inline-render-with-function (handle func &rest args)
347   (let ((source (mm-get-part handle)))
348     (mm-insert-inline 
349      handle 
350      (mm-with-unibyte-buffer
351        (insert source)
352        (apply func args)
353        (buffer-string)))))
354
355 (defun mm-inline-text-html (handle)
356   (let* ((func (or mm-inline-text-html-renderer mm-text-html-renderer))
357          (entry (assq func mm-text-html-renderer-alist))
358          buffer-read-only)
359     (if entry
360         (setq func (cdr entry)))
361     (cond
362      ((gnus-functionp func)
363       (funcall func handle))
364      (t
365       (apply (car func) handle (cdr func))))))
366
367 (defun mm-inline-text-vcard (handle)
368   (let (buffer-read-only)
369     (mm-insert-inline
370      handle
371      (concat "\n-- \n"
372              (ignore-errors
373                (if (fboundp 'vcard-pretty-print)
374                    (vcard-pretty-print (mm-get-part handle))
375                  (vcard-format-string
376                   (vcard-parse-string (mm-get-part handle)
377                                       'vcard-standard-filter))))))))
378
379 (defun mm-inline-text (handle)
380   (let ((b (point))
381         (type (mm-handle-media-subtype handle))
382         (charset (mail-content-type-get
383                   (mm-handle-type handle) 'charset))
384         buffer-read-only)
385     (if (or (eq charset 'gnus-decoded)
386             ;; This is probably not entirely correct, but
387             ;; makes rfc822 parts with embedded multiparts work.
388             (eq mail-parse-charset 'gnus-decoded))
389         (save-restriction
390           (narrow-to-region (point) (point))
391           (mm-insert-part handle)
392           (goto-char (point-max)))
393       (insert (mm-decode-string (mm-get-part handle) charset)))
394     (when (and (equal type "plain")
395                (equal (cdr (assoc 'format (mm-handle-type handle)))
396                       "flowed"))
397       (save-restriction
398         (narrow-to-region b (point))
399         (goto-char b)
400         (fill-flowed)
401         (goto-char (point-max))))
402     (save-restriction
403       (narrow-to-region b (point))
404       (set-text-properties (point-min) (point-max) nil)
405       (when (or (equal type "enriched")
406                 (equal type "richtext"))
407         (enriched-decode (point-min) (point-max)))
408       (mm-handle-set-undisplayer
409        handle
410        `(lambda ()
411           (let (buffer-read-only)
412             (delete-region ,(point-min-marker)
413                            ,(point-max-marker))))))))
414
415 (defun mm-insert-inline (handle text)
416   "Insert TEXT inline from HANDLE."
417   (let ((b (point)))
418     (insert text)
419     (mm-handle-set-undisplayer
420      handle
421      `(lambda ()
422         (let (buffer-read-only)
423           (delete-region ,(set-marker (make-marker) b)
424                          ,(set-marker (make-marker) (point))))))))
425
426 (defun mm-inline-audio (handle)
427   (message "Not implemented"))
428
429 (defun mm-view-sound-file ()
430   (message "Not implemented"))
431
432 (defun mm-w3-prepare-buffer ()
433   (require 'w3)
434   (let ((url-standalone-mode t)
435         (url-gateway-unplugged t)
436         (w3-honor-stylesheets nil)
437         (w3-delay-image-loads t))
438     (w3-prepare-buffer)))
439
440 (defun mm-view-message ()
441   (mm-enable-multibyte)
442   (let (handles)
443     (let (gnus-article-mime-handles)
444       ;; Double decode problem may happen.  See mm-inline-message.
445       (run-hooks 'gnus-article-decode-hook)
446       (gnus-article-prepare-display)
447       (setq handles gnus-article-mime-handles))
448     (when handles
449       (setq gnus-article-mime-handles
450             (mm-merge-handles gnus-article-mime-handles handles))))
451   (fundamental-mode)
452   (goto-char (point-min)))
453
454 (defun mm-inline-message (handle)
455   (let ((b (point))
456         (bolp (bolp))
457         (charset (mail-content-type-get
458                   (mm-handle-type handle) 'charset))
459         gnus-displaying-mime handles)
460     (when (and charset
461                (stringp charset))
462       (setq charset (intern (downcase charset)))
463       (when (eq charset 'us-ascii)
464         (setq charset nil)))
465     (save-excursion
466       (save-restriction
467         (narrow-to-region b b)
468         (mm-insert-part handle)
469         (let (gnus-article-mime-handles
470               ;; disable prepare hook
471               gnus-article-prepare-hook
472               (gnus-newsgroup-charset
473                (or charset gnus-newsgroup-charset)))
474           (run-hooks 'gnus-article-decode-hook)
475           (gnus-article-prepare-display)
476           (setq handles gnus-article-mime-handles))
477         (goto-char (point-min))
478         (unless bolp
479           (insert "\n"))
480         (goto-char (point-max))
481         (unless (bolp)
482           (insert "\n"))
483         (insert "----------\n\n")
484         (when handles
485           (setq gnus-article-mime-handles
486                 (mm-merge-handles gnus-article-mime-handles handles)))
487         (mm-handle-set-undisplayer
488          handle
489          `(lambda ()
490             (let (buffer-read-only)
491               (if (fboundp 'remove-specifier)
492                   ;; This is only valid on XEmacs.
493                   (mapcar (lambda (prop)
494                             (remove-specifier
495                              (face-property 'default prop) (current-buffer)))
496                           '(background background-pixmap foreground)))
497               (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
498
499 (defun mm-display-inline-fontify (handle mode)
500   (let (text)
501     ;; XEmacs @#$@ version of font-lock refuses to fully turn itself
502     ;; on for buffers whose name begins with " ".  That's why we use
503     ;; save-current-buffer/get-buffer-create rather than
504     ;; with-temp-buffer.
505     (save-current-buffer
506       (set-buffer (generate-new-buffer "*fontification*"))
507       (unwind-protect
508           (progn
509             (buffer-disable-undo)
510             (mm-insert-part handle)
511             (funcall mode)
512             (require 'font-lock)
513             (let ((font-lock-verbose nil))
514               ;; I find font-lock a bit too verbose.
515               (font-lock-fontify-buffer))
516             ;; By default, XEmacs font-lock uses non-duplicable text
517             ;; properties.  This code forces all the text properties
518             ;; to be copied along with the text.
519             (when (fboundp 'extent-list)
520               (map-extents (lambda (ext ignored)
521                              (set-extent-property ext 'duplicable t)
522                              nil)
523                            nil nil nil nil nil 'text-prop))
524             (setq text (buffer-string)))
525         (kill-buffer (current-buffer))))
526     (mm-insert-inline handle text)))
527
528 ;; Shouldn't these functions check whether the user even wants to use
529 ;; font-lock?  At least under XEmacs, this fontification is pretty
530 ;; much unconditional.  Also, it would be nice to change for the size
531 ;; of the fontified region.
532
533 (defun mm-display-patch-inline (handle)
534   (mm-display-inline-fontify handle 'diff-mode))
535
536 (defun mm-display-elisp-inline (handle)
537   (mm-display-inline-fontify handle 'emacs-lisp-mode))
538
539 ;;      id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
540 ;;          us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 }
541 (defvar mm-pkcs7-signed-magic
542   (mm-string-as-unibyte
543    (apply 'concat
544           (mapcar 'char-to-string
545                   (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c
546                         ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e
547                         ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48
548                         ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x02)))))
549   
550 ;;      id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
551 ;;          us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 }
552 (defvar mm-pkcs7-enveloped-magic
553   (mm-string-as-unibyte
554    (apply 'concat
555           (mapcar 'char-to-string
556                   (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c
557                         ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e
558                         ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48
559                         ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x03)))))
560   
561 (defun mm-view-pkcs7-get-type (handle)
562   (mm-with-unibyte-buffer
563     (mm-insert-part handle)
564     (cond ((looking-at mm-pkcs7-enveloped-magic)
565            'enveloped)
566           ((looking-at mm-pkcs7-signed-magic)
567            'signed)
568           (t
569            (error "Could not identify PKCS#7 type")))))
570
571 (defun mm-view-pkcs7 (handle)
572   (case (mm-view-pkcs7-get-type handle)
573     (enveloped (mm-view-pkcs7-decrypt handle))
574     (otherwise (error "Unknown or unimplemented PKCS#7 type"))))
575
576 (defun mm-view-pkcs7-decrypt (handle)
577   (insert-buffer (mm-handle-buffer handle))
578   (goto-char (point-min))
579   (insert "MIME-Version: 1.0\n")
580   (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m")
581   (smime-decrypt-region
582    (point-min) (point-max)
583    (if (= (length smime-keys) 1)
584        (cadar smime-keys)
585      (smime-get-key-by-email
586       (completing-read "Decrypt this part with which key? "
587                        smime-keys nil nil
588                        (and (listp (car-safe smime-keys))
589                             (caar smime-keys)))))))
590
591 (provide 'mm-view)
592
593 ;;; mm-view.el ends here