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

   1 ;;; mm-view.el --- functions for viewing MIME objects
   2
   3 ;; Copyright (C) 1998-2015 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