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