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