cgit.sxemacs.org Git - gnus/blob - lisp/mm-view.el

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