mm-view.el (mm-display-inline-fontify): Make the working buffer temporarily displayed...
[gnus] / lisp / mm-view.el
1 ;;; mm-view.el --- functions for viewing MIME objects
2
3 ;; Copyright (C) 1998-2014 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 3 of the License, or
11 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; Code:
24
25 (eval-when-compile (require 'cl))
26 (require 'mail-parse)
27 (require 'mailcap)
28 (require 'mm-bodies)
29 (require 'mm-decode)
30 (require 'smime)
31 (require 'mml-smime)
32
33 (autoload 'gnus-completing-read "gnus-util")
34 (autoload 'gnus-window-inside-pixel-edges "gnus-ems")
35 (autoload 'gnus-article-prepare-display "gnus-art")
36 (autoload 'vcard-parse-string "vcard")
37 (autoload 'vcard-format-string "vcard")
38 (autoload 'fill-flowed "flow-fill")
39 (autoload 'html2text "html2text" nil t)
40
41 (defvar gnus-article-mime-handles)
42 (defvar gnus-newsgroup-charset)
43 (defvar smime-keys)
44 (defvar w3m-cid-retrieve-function-alist)
45 (defvar w3m-current-buffer)
46 (defvar w3m-display-inline-images)
47 (defvar w3m-minor-mode-map)
48
49 (defvar mm-text-html-renderer-alist
50   '((shr . mm-shr)
51     (w3m . mm-inline-text-html-render-with-w3m)
52     (w3m-standalone . mm-inline-text-html-render-with-w3m-standalone)
53     (gnus-w3m . gnus-article-html)
54     (links mm-inline-render-with-file
55            mm-links-remove-leading-blank
56            "links" "-dump" file)
57     (lynx mm-inline-render-with-stdin nil
58           "lynx" "-dump" "-force_html" "-stdin" "-nolist")
59     (html2text mm-inline-render-with-function html2text))
60   "The attributes of renderer types for text/html.")
61
62 (defcustom mm-fill-flowed t
63   "If non-nil a format=flowed article will be displayed flowed."
64   :type 'boolean
65   :version "22.1"
66   :group 'mime-display)
67
68 (defcustom mm-inline-large-images-proportion 0.9
69   "Maximum proportion of large image resized when
70 `mm-inline-large-images' is set to resize."
71   :type 'float
72   :version "24.1"
73   :group 'mime-display)
74
75 ;;; Internal variables.
76
77 ;;;
78 ;;; Functions for displaying various formats inline
79 ;;;
80
81 (autoload 'gnus-rescale-image "gnus-util")
82
83 (defun mm-inline-image-emacs (handle)
84   (let ((b (point-marker))
85         (inhibit-read-only t))
86     (put-image
87      (let ((image (mm-get-image handle)))
88        (if (eq mm-inline-large-images 'resize)
89            (gnus-rescale-image
90             image
91             (let ((edges (gnus-window-inside-pixel-edges
92                           (get-buffer-window (current-buffer)))))
93               (cons (truncate (* mm-inline-large-images-proportion
94                                  (- (nth 2 edges) (nth 0 edges))))
95                     (truncate (* mm-inline-large-images-proportion
96                                  (- (nth 3 edges) (nth 1 edges)))))))
97          image))
98      b)
99     (insert "\n")
100     (mm-handle-set-undisplayer
101      handle
102      `(lambda ()
103         (let ((b ,b)
104               (inhibit-read-only t))
105           (remove-images b b)
106           (delete-region b (1+ b)))))))
107
108 (defun mm-inline-image-xemacs (handle)
109   (when (featurep 'xemacs)
110     (insert "\n")
111     (forward-char -1)
112     (let ((annot (make-annotation (mm-get-image handle) nil 'text))
113         (inhibit-read-only t))
114       (mm-handle-set-undisplayer
115        handle
116        `(lambda ()
117           (let ((b ,(point-marker))
118               (inhibit-read-only t))
119             (delete-annotation ,annot)
120             (delete-region (1- b) b))))
121       (set-extent-property annot 'mm t)
122       (set-extent-property annot 'duplicable t))))
123
124 (eval-and-compile
125   (if (featurep 'xemacs)
126       (defalias 'mm-inline-image 'mm-inline-image-xemacs)
127     (defalias 'mm-inline-image 'mm-inline-image-emacs)))
128
129 (defvar mm-w3m-setup nil
130   "Whether gnus-article-mode has been setup to use emacs-w3m.")
131
132 ;; External.
133 (declare-function w3m-detect-meta-charset "ext:w3m" ())
134 (declare-function w3m-region "ext:w3m" (start end &optional url charset))
135
136 (defun mm-setup-w3m ()
137   "Setup gnus-article-mode to use emacs-w3m."
138   (unless mm-w3m-setup
139     (require 'w3m)
140     (unless (assq 'gnus-article-mode w3m-cid-retrieve-function-alist)
141       (push (cons 'gnus-article-mode 'mm-w3m-cid-retrieve)
142             w3m-cid-retrieve-function-alist))
143     (setq mm-w3m-setup t))
144   (setq w3m-display-inline-images mm-inline-text-html-with-images))
145
146 (defun mm-w3m-cid-retrieve-1 (url handle)
147   (dolist (elem handle)
148     (when (consp elem)
149       (when (equal url (mm-handle-id elem))
150         (mm-insert-part elem)
151         (throw 'found-handle (mm-handle-media-type elem)))
152       (when (and (stringp (car elem))
153                  (equal "multipart" (mm-handle-media-supertype elem)))
154         (mm-w3m-cid-retrieve-1 url elem)))))
155
156 (defun mm-w3m-cid-retrieve (url &rest args)
157   "Insert a content pointed by URL if it has the cid: scheme."
158   (when (string-match "\\`cid:" url)
159     (or (catch 'found-handle
160           (mm-w3m-cid-retrieve-1
161            (setq url (concat "<" (substring url (match-end 0)) ">"))
162            (with-current-buffer w3m-current-buffer
163              gnus-article-mime-handles)))
164         (prog1
165             nil
166           (message "Failed to find \"Content-ID: %s\"" url)))))
167
168 (defun mm-inline-text-html-render-with-w3m (handle)
169   "Render a text/html part using emacs-w3m."
170   (mm-setup-w3m)
171   (let ((text (mm-get-part handle))
172         (b (point))
173         (charset (or (mail-content-type-get (mm-handle-type handle) 'charset)
174                      mail-parse-charset)))
175     (save-excursion
176       (insert (if charset (mm-decode-string text charset) text))
177       (save-restriction
178         (narrow-to-region b (point))
179         (unless charset
180           (goto-char (point-min))
181           (when (setq charset (w3m-detect-meta-charset))
182             (delete-region (point-min) (point-max))
183             (insert (mm-decode-string text charset))))
184         (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
185               w3m-force-redisplay)
186           (w3m-region (point-min) (point-max) nil charset))
187         ;; Put the mark meaning this part was rendered by emacs-w3m.
188         (put-text-property (point-min) (point-max)
189                            'mm-inline-text-html-with-w3m t)
190         (when (and mm-inline-text-html-with-w3m-keymap
191                    (boundp 'w3m-minor-mode-map)
192                    w3m-minor-mode-map)
193           (if (and (boundp 'w3m-link-map)
194                    w3m-link-map)
195               (let* ((start (point-min))
196                      (end (point-max))
197                      (on (get-text-property start 'w3m-href-anchor))
198                      (map (copy-keymap w3m-link-map))
199                      next)
200                 (set-keymap-parent map w3m-minor-mode-map)
201                 (while (< start end)
202                   (if on
203                       (progn
204                         (setq next (or (text-property-any start end
205                                                           'w3m-href-anchor nil)
206                                        end))
207                         (put-text-property start next 'keymap map))
208                     (setq next (or (text-property-not-all start end
209                                                           'w3m-href-anchor nil)
210                                    end))
211                     (put-text-property start next 'keymap w3m-minor-mode-map))
212                   (setq start next
213                         on (not on))))
214             (put-text-property (point-min) (point-max)
215                                'keymap w3m-minor-mode-map)))
216         (mm-handle-set-undisplayer
217          handle
218          `(lambda ()
219             (let ((inhibit-read-only t))
220               (delete-region ,(copy-marker (point-min) t)
221                              ,(point-max-marker)))))))))
222
223 (defvar mm-w3m-standalone-supports-m17n-p (if (featurep 'mule) 'undecided)
224   "*T means the w3m command supports the m17n feature.")
225
226 (defun mm-w3m-standalone-supports-m17n-p ()
227   "Say whether the w3m command supports the m17n feature."
228   (cond ((eq mm-w3m-standalone-supports-m17n-p t) t)
229         ((eq mm-w3m-standalone-supports-m17n-p nil) nil)
230         ((not (featurep 'mule)) (setq mm-w3m-standalone-supports-m17n-p nil))
231         ((condition-case nil
232              (let ((coding-system-for-write 'iso-2022-jp)
233                    (coding-system-for-read 'iso-2022-jp)
234                    (str (mm-decode-coding-string "\
235 \e$B#D#o#e#s!!#w#3#m!!#s#u#p#p#o#r#t!!#m#1#7#n!)\e(B" 'iso-2022-jp)))
236                (mm-with-multibyte-buffer
237                  (insert str)
238                  (call-process-region
239                   (point-min) (point-max) "w3m" t t nil "-dump"
240                   "-T" "text/html" "-I" "iso-2022-jp" "-O" "iso-2022-jp")
241                  (goto-char (point-min))
242                  (search-forward str nil t)))
243            (error nil))
244          (setq mm-w3m-standalone-supports-m17n-p t))
245         (t
246          ;;(message "You had better upgrade your w3m command")
247          (setq mm-w3m-standalone-supports-m17n-p nil))))
248
249 (defun mm-inline-text-html-render-with-w3m-standalone (handle)
250   "Render a text/html part using w3m."
251   (if (mm-w3m-standalone-supports-m17n-p)
252       (let ((source (mm-get-part handle))
253             (charset (or (mail-content-type-get (mm-handle-type handle)
254                                                 'charset)
255                          (symbol-name mail-parse-charset)))
256             cs)
257         (if (and charset
258                  (setq cs (mm-charset-to-coding-system charset nil t))
259                  (not (eq cs 'ascii)))
260             (setq charset (format "%s" (mm-coding-system-to-mime-charset cs)))
261           ;; The default.
262           (setq charset "iso-8859-1"
263                 cs 'iso-8859-1))
264         (mm-insert-inline
265          handle
266          (mm-with-unibyte-buffer
267            (insert source)
268            (mm-enable-multibyte)
269            (let ((coding-system-for-write 'binary)
270                  (coding-system-for-read cs))
271              (call-process-region
272               (point-min) (point-max)
273               "w3m" t t nil "-dump" "-T" "text/html"
274               "-I" charset "-O" charset))
275            (buffer-string))))
276     (mm-inline-render-with-stdin handle nil "w3m" "-dump" "-T" "text/html")))
277
278 (defun mm-links-remove-leading-blank ()
279   ;; Delete the annoying three spaces preceding each line of links
280   ;; output.
281   (goto-char (point-min))
282   (while (re-search-forward "^   " nil t)
283     (delete-region (match-beginning 0) (match-end 0))))
284
285 (defun mm-inline-wash-with-file (post-func cmd &rest args)
286   (let ((file (mm-make-temp-file
287                (expand-file-name "mm" mm-tmp-directory))))
288     (let ((coding-system-for-write 'binary))
289       (write-region (point-min) (point-max) file nil 'silent))
290     (delete-region (point-min) (point-max))
291     (unwind-protect
292         (apply 'call-process cmd nil t nil (mapcar 'eval args))
293       (delete-file file))
294     (and post-func (funcall post-func))))
295
296 (defun mm-inline-wash-with-stdin (post-func cmd &rest args)
297   (let ((coding-system-for-write 'binary))
298     (apply 'call-process-region (point-min) (point-max)
299            cmd t t nil args))
300   (and post-func (funcall post-func)))
301
302 (defun mm-inline-render-with-file (handle post-func cmd &rest args)
303   (let ((source (mm-get-part handle)))
304     (mm-insert-inline
305      handle
306      (mm-with-unibyte-buffer
307        (insert source)
308        (apply 'mm-inline-wash-with-file post-func cmd args)
309        (buffer-string)))))
310
311 (defun mm-inline-render-with-stdin (handle post-func cmd &rest args)
312   (let ((source (mm-get-part handle)))
313     (mm-insert-inline
314      handle
315      (mm-with-unibyte-buffer
316        (insert source)
317        (apply 'mm-inline-wash-with-stdin post-func cmd args)
318        (buffer-string)))))
319
320 (defun mm-inline-render-with-function (handle func &rest args)
321   (let ((source (mm-get-part handle))
322         (charset (or (mail-content-type-get (mm-handle-type handle) 'charset)
323                      mail-parse-charset)))
324     (mm-insert-inline
325      handle
326      (mm-with-multibyte-buffer
327        (insert (if charset
328                    (mm-decode-string source charset)
329                  source))
330        (apply func args)
331        (buffer-string)))))
332
333 (defun mm-inline-text-html (handle)
334   (if (stringp (car handle))
335       (mapcar 'mm-inline-text-html (cdr handle))
336     (let* ((func mm-text-html-renderer)
337            (entry (assq func mm-text-html-renderer-alist))
338            (inhibit-read-only t))
339       (if entry
340           (setq func (cdr entry)))
341       (cond
342        ((functionp func)
343         (funcall func handle))
344        (t
345         (apply (car func) handle (cdr func)))))))
346
347 (defun mm-inline-text-vcard (handle)
348   (let ((inhibit-read-only t))
349     (mm-insert-inline
350      handle
351      (concat "\n-- \n"
352              (ignore-errors
353                (if (fboundp 'vcard-pretty-print)
354                    (vcard-pretty-print (mm-get-part handle))
355                  (vcard-format-string
356                   (vcard-parse-string (mm-get-part handle)
357                                       'vcard-standard-filter))))))))
358
359 (defun mm-inline-text (handle)
360   (let ((b (point))
361         (type (mm-handle-media-subtype handle))
362         (charset (mail-content-type-get
363                   (mm-handle-type handle) 'charset))
364         (inhibit-read-only t))
365     (if (or (eq charset 'gnus-decoded)
366             ;; This is probably not entirely correct, but
367             ;; makes rfc822 parts with embedded multiparts work.
368             (eq mail-parse-charset 'gnus-decoded))
369         (save-restriction
370           (narrow-to-region (point) (point))
371           (mm-insert-part handle)
372           (goto-char (point-max)))
373       (mm-display-inline-fontify handle))
374     (when (and mm-fill-flowed
375                (equal type "plain")
376                (equal (cdr (assoc 'format (mm-handle-type handle)))
377                       "flowed"))
378       (save-restriction
379         (narrow-to-region b (point))
380         (goto-char b)
381         (fill-flowed nil (equal (cdr (assoc 'delsp (mm-handle-type handle)))
382                                 "yes"))
383         (goto-char (point-max))))
384     (save-restriction
385       (narrow-to-region b (point))
386       (when (member type '("enriched" "richtext"))
387         (set-text-properties (point-min) (point-max) nil)
388         (ignore-errors
389           (enriched-decode (point-min) (point-max))))
390       (mm-handle-set-undisplayer
391        handle
392        `(lambda ()
393           (let ((inhibit-read-only t))
394             (delete-region ,(copy-marker (point-min) t)
395                            ,(point-max-marker))))))))
396
397 (defun mm-insert-inline (handle text)
398   "Insert TEXT inline from HANDLE."
399   (let ((b (point)))
400     (insert text)
401     (unless (bolp)
402       (insert "\n"))
403     (mm-handle-set-undisplayer
404      handle
405      `(lambda ()
406         (let ((inhibit-read-only t))
407           (delete-region ,(copy-marker b t)
408                          ,(point-marker)))))))
409
410 (defun mm-inline-audio (handle)
411   (message "Not implemented"))
412
413 (defun mm-view-message ()
414   (mm-enable-multibyte)
415   (let (handles)
416     (let (gnus-article-mime-handles)
417       ;; Double decode problem may happen.  See mm-inline-message.
418       (run-hooks 'gnus-article-decode-hook)
419       (gnus-article-prepare-display)
420       (setq handles gnus-article-mime-handles))
421     (when handles
422       (setq gnus-article-mime-handles
423             (mm-merge-handles gnus-article-mime-handles handles))))
424   (fundamental-mode)
425   (goto-char (point-min)))
426
427 (defun mm-inline-message (handle)
428   (let ((b (point))
429         (bolp (bolp))
430         (charset (mail-content-type-get
431                   (mm-handle-type handle) 'charset))
432         gnus-displaying-mime handles)
433     (when (and charset
434                (stringp charset))
435       (setq charset (intern (downcase charset)))
436       (when (eq charset 'us-ascii)
437         (setq charset nil)))
438     (save-excursion
439       (save-restriction
440         (narrow-to-region b b)
441         (mm-insert-part handle)
442         (let (gnus-article-mime-handles
443               ;; disable prepare hook
444               gnus-article-prepare-hook
445               (gnus-newsgroup-charset
446                (unless (eq charset 'gnus-decoded) ;; mm-uu might set it.
447                  (or charset gnus-newsgroup-charset))))
448           (let ((gnus-original-article-buffer (mm-handle-buffer handle)))
449             (run-hooks 'gnus-article-decode-hook))
450           (gnus-article-prepare-display)
451           (setq handles gnus-article-mime-handles))
452         (goto-char (point-min))
453         (unless bolp
454           (insert "\n"))
455         (goto-char (point-max))
456         (unless (bolp)
457           (insert "\n"))
458         (insert "----------\n\n")
459         (when handles
460           (setq gnus-article-mime-handles
461                 (mm-merge-handles gnus-article-mime-handles handles)))
462         (mm-handle-set-undisplayer
463          handle
464          `(lambda ()
465             (let ((inhibit-read-only t))
466               (if (fboundp 'remove-specifier)
467                   ;; This is only valid on XEmacs.
468                   (dolist (prop '(background background-pixmap foreground))
469                     (remove-specifier
470                      (face-property 'default prop) (current-buffer))))
471               (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
472
473 ;; Shut up byte-compiler.
474 (defvar font-lock-mode-hook)
475 (defun mm-display-inline-fontify (handle &optional mode)
476   "Insert HANDLE inline fontifying with MODE.
477 If MODE is not set, try to find mode automatically."
478   (let ((charset (mail-content-type-get (mm-handle-type handle) 'charset))
479         text coding-system)
480     (unless (eq charset 'gnus-decoded)
481       (mm-with-unibyte-buffer
482         (mm-insert-part handle)
483         (mm-decompress-buffer
484          (mm-handle-filename handle)
485          t t)
486         (unless charset
487           (setq coding-system (mm-find-buffer-file-coding-system)))
488         (setq text (buffer-string))))
489     ;; XEmacs @#$@ version of font-lock refuses to fully turn itself
490     ;; on for buffers whose name begins with " ".  That's why we use
491     ;; `with-current-buffer'/`generate-new-buffer' rather than
492     ;; `with-temp-buffer'.
493     (with-current-buffer (generate-new-buffer "*fontification*")
494       (buffer-disable-undo)
495       (mm-enable-multibyte)
496       (insert (cond ((eq charset 'gnus-decoded)
497                      (with-current-buffer (mm-handle-buffer handle)
498                        (buffer-string)))
499                     (coding-system
500                      (mm-decode-coding-string text coding-system))
501                     (charset
502                      (mm-decode-string text charset))
503                     (t
504                      text)))
505       (require 'font-lock)
506       ;; I find font-lock a bit too verbose.
507       (let ((font-lock-verbose nil)
508             (font-lock-support-mode nil))
509         ;; Disable support modes, e.g., jit-lock, lazy-lock, etc.
510         ;; Note: XEmacs people use `font-lock-mode-hook' to run those modes.
511         (set (make-local-variable 'font-lock-mode-hook) nil)
512         (setq buffer-file-name (mm-handle-filename handle))
513         (set (make-local-variable 'enable-local-variables) nil)
514         (with-demoted-errors
515           (if mode
516               (save-window-excursion
517                 (switch-to-buffer (current-buffer))
518                 (funcall mode))
519             (let ((auto-mode-alist
520                    (delq (rassq 'doc-view-mode-maybe auto-mode-alist)
521                          (copy-sequence auto-mode-alist))))
522               (set-auto-mode)))
523           ;; The mode function might have already turned on font-lock.
524           ;; Do not fontify if the guess mode is fundamental.
525           (unless (or font-lock-mode
526                       (eq major-mode 'fundamental-mode))
527             (if (fboundp 'font-lock-ensure)
528                 (font-lock-ensure)
529               (font-lock-fontify-buffer)))))
530       ;; By default, XEmacs font-lock uses non-duplicable text
531       ;; properties.  This code forces all the text properties
532       ;; to be copied along with the text.
533       (when (featurep 'xemacs)
534         (map-extents (lambda (ext ignored)
535                        (set-extent-property ext 'duplicable t)
536                        nil)
537                      nil nil nil nil nil 'text-prop))
538       (setq text (buffer-string))
539       ;; Set buffer unmodified to avoid confirmation when killing the
540       ;; buffer.
541       (set-buffer-modified-p nil)
542       (kill-buffer (current-buffer)))
543     (mm-insert-inline handle text)))
544
545 ;; Shouldn't these functions check whether the user even wants to use
546 ;; font-lock?  At least under XEmacs, this fontification is pretty
547 ;; much unconditional.  Also, it would be nice to change for the size
548 ;; of the fontified region.
549
550 (defun mm-display-patch-inline (handle)
551   (mm-display-inline-fontify handle 'diff-mode))
552
553 (defun mm-display-elisp-inline (handle)
554   (mm-display-inline-fontify handle 'emacs-lisp-mode))
555
556 (defun mm-display-dns-inline (handle)
557   (mm-display-inline-fontify handle 'dns-mode))
558
559 (defun mm-display-org-inline (handle)
560   "Show an Org mode text from HANDLE inline."
561   (mm-display-inline-fontify handle 'org-mode))
562
563 (defun mm-display-shell-script-inline (handle)
564   "Show a shell script from HANDLE inline."
565   (mm-display-inline-fontify handle 'shell-script-mode))
566
567 (defun mm-display-javascript-inline (handle)
568   "Show JavsScript code from HANDLE inline."
569   (mm-display-inline-fontify handle 'javascript-mode))
570
571 ;;      id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
572 ;;          us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 }
573 (defvar mm-pkcs7-signed-magic
574   (concat
575     "0"
576     "\\(\\(\x80\\)"
577     "\\|\\(\x81\\(.\\|\n\\)\\{1\\}\\)"
578     "\\|\\(\x82\\(.\\|\n\\)\\{2\\}\\)"
579     "\\|\\(\x83\\(.\\|\n\\)\\{3\\}\\)"
580     "\\)"
581     "\x06\x09\\*\x86H\x86\xf7\x0d\x01\x07\x02"))
582
583 ;;      id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
584 ;;          us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 }
585 (defvar mm-pkcs7-enveloped-magic
586   (concat
587     "0"
588     "\\(\\(\x80\\)"
589     "\\|\\(\x81\\(.\\|\n\\)\\{1\\}\\)"
590     "\\|\\(\x82\\(.\\|\n\\)\\{2\\}\\)"
591     "\\|\\(\x83\\(.\\|\n\\)\\{3\\}\\)"
592     "\\)"
593     "\x06\x09\\*\x86H\x86\xf7\x0d\x01\x07\x03"))
594
595 (defun mm-view-pkcs7-get-type (handle)
596   (mm-with-unibyte-buffer
597     (mm-insert-part handle)
598     (cond ((looking-at mm-pkcs7-enveloped-magic)
599            'enveloped)
600           ((looking-at mm-pkcs7-signed-magic)
601            'signed)
602           (t
603            (error "Could not identify PKCS#7 type")))))
604
605 (defun mm-view-pkcs7 (handle &optional from)
606   (case (mm-view-pkcs7-get-type handle)
607     (enveloped (mm-view-pkcs7-decrypt handle from))
608     (signed (mm-view-pkcs7-verify handle))
609     (otherwise (error "Unknown or unimplemented PKCS#7 type"))))
610
611 (defun mm-view-pkcs7-verify (handle)
612   (let ((verified nil))
613     (with-temp-buffer
614       (insert "MIME-Version: 1.0\n")
615       (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m")
616       (insert-buffer-substring (mm-handle-buffer handle))
617       (setq verified (smime-verify-region (point-min) (point-max))))
618     (goto-char (point-min))
619     (mm-insert-part handle)
620     (if (search-forward "Content-Type: " nil t)
621         (delete-region (point-min) (match-beginning 0)))
622     (goto-char (point-max))
623     (if (re-search-backward "--\r?\n?" nil t)
624         (delete-region (match-end 0) (point-max)))
625     (unless verified
626       (insert-buffer-substring smime-details-buffer)))
627   (goto-char (point-min))
628   (while (search-forward "\r\n" nil t)
629     (replace-match "\n"))
630   t)
631
632 (defun mm-view-pkcs7-decrypt (handle &optional from)
633   (insert-buffer-substring (mm-handle-buffer handle))
634   (goto-char (point-min))
635   (if (eq mml-smime-use 'epg)
636       ;; Use EPG/gpgsm
637       (let ((part (base64-decode-string (buffer-string))))
638         (erase-buffer)
639         (insert (epg-decrypt-string (epg-make-context 'CMS) part)))
640     ;; Use openssl
641     (insert "MIME-Version: 1.0\n")
642     (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m")
643     (smime-decrypt-region
644      (point-min) (point-max)
645      (if (= (length smime-keys) 1)
646          (cadar smime-keys)
647        (smime-get-key-by-email
648         (gnus-completing-read
649          "Decipher using key"
650          smime-keys nil nil nil (car-safe (car-safe smime-keys)))))
651      from))
652   (goto-char (point-min))
653   (while (search-forward "\r\n" nil t)
654     (replace-match "\n"))
655   (goto-char (point-min)))
656
657 (provide 'mm-view)
658
659 ;;; mm-view.el ends here