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