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