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