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