/[emacs]/emacs/lisp/gnus/mm-view.el
ViewVC logotype

Diff of /emacs/lisp/gnus/mm-view.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7.4.3 by miles, Tue Jul 6 09:23:45 2004 UTC revision 1.7.4.4 by miles, Thu Sep 16 00:12:16 2004 UTC
# Line 1  Line 1 
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.
# Line 34  Line 35 
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    
# Line 80  Line 114 
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
# Line 216  Line 389 
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 ()
# Line 229  Line 403 
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    
# Line 255  Line 427 
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))
# Line 267  Line 440 
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 ()
# Line 284  Line 455 
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

Legend:
Removed from v.1.7.4.3  
changed lines
  Added in v.1.7.4.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26