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