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