lisp/gnus/mm-view.el

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