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