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