cgit.sxemacs.org Git - gnus/blob - lisp/mm-view.el

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