Mercurial > emacs

comparison lisp/gnus/mm-view.el @ 88155:d7ddb3e565de

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