lisp/gnus/mm-view.el

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