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