git.chise.org Git - elisp/gnus.git-/blob - lisp/mm-view.el

   1 ;;; mm-view.el --- functions for viewing MIME objects
   2 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2, or (at your option)
  10 ;; any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 ;; Boston, MA 02111-1307, USA.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 (eval-when-compile (require 'cl))
  27 (require 'mail-parse)
  28 (require 'mailcap)
  29 (require 'mm-bodies)
  30 (require 'mm-decode)
  31
  32 (eval-and-compile
  33   (autoload 'gnus-article-prepare-display "gnus-art")
  34   (autoload 'vcard-parse-string "vcard")
  35   (autoload 'vcard-format-string "vcard")
  36   (autoload 'fill-flowed "flow-fill")
  37   (unless (fboundp 'diff-mode)
  38     (autoload 'diff-mode "diff-mode" "" t nil)))
  39
  40 ;;;
  41 ;;; Functions for displaying various formats inline
  42 ;;;
  43
  44 (defun mm-inline-image-emacs (handle)
  45   (let ((b (point-marker))
  46         buffer-read-only)
  47     (insert "\n")
  48     (put-image (mm-get-image handle) b)
  49     (mm-handle-set-undisplayer
  50      handle
  51      `(lambda () (remove-images ,b (1+ ,b))))))
  52
  53 (defun mm-inline-image-xemacs (handle)
  54   (insert "\n")
  55   (forward-char -1)
  56   (let ((b (point))
  57         (annot (make-annotation (mm-get-image handle) nil 'text))
  58         buffer-read-only)
  59     (mm-handle-set-undisplayer
  60      handle
  61      `(lambda ()
  62         (let (buffer-read-only)
  63           (delete-annotation ,annot)
  64           (delete-region ,(set-marker (make-marker) b)
  65                          ,(set-marker (make-marker) (point))))))
  66     (set-extent-property annot 'mm t)
  67     (set-extent-property annot 'duplicable t)))
  68
  69 (eval-and-compile
  70   (if (featurep 'xemacs)
  71       (defalias 'mm-inline-image 'mm-inline-image-xemacs)
  72     (defalias 'mm-inline-image 'mm-inline-image-emacs)))
  73
  74 (defvar mm-w3-setup nil)
  75 (defun mm-setup-w3 ()
  76   (unless mm-w3-setup
  77     (require 'w3)
  78     (w3-do-setup)
  79     (require 'url)
  80     (require 'w3-vars)
  81     (require 'url-vars)
  82     (setq mm-w3-setup t)))
  83
  84 (defun mm-inline-text (handle)
  85   (let ((type (mm-handle-media-subtype handle))
  86         text buffer-read-only)
  87     (cond
  88      ((equal type "html")
  89       (mm-setup-w3)
  90       (setq text (mm-get-part handle))
  91       (let ((b (point))
  92             (url-standalone-mode t)
  93             (w3-honor-stylesheets nil)
  94             (w3-delay-image-loads t)
  95             (url-current-object
  96              (url-generic-parse-url (format "cid:%s" (mm-handle-id handle))))
  97             (width (window-width))
  98             (charset (mail-content-type-get
  99                       (mm-handle-type handle) 'charset)))
 100         (save-excursion
 101           (insert text)
 102           (save-restriction
 103             (narrow-to-region b (point))
 104             (goto-char (point-min))
 105             (if (or (and (boundp 'w3-meta-content-type-charset-regexp)
 106                          (re-search-forward
 107                           w3-meta-content-type-charset-regexp nil t))
 108                     (and (boundp 'w3-meta-charset-content-type-regexp)
 109                          (re-search-forward
 110                           w3-meta-charset-content-type-regexp nil t)))
 111                 (setq charset
 112                       (or (let ((bsubstr (buffer-substring-no-properties
 113                                           (match-beginning 2)
 114                                           (match-end 2))))
 115                             (if (fboundp 'w3-coding-system-for-mime-charset)
 116                                 (w3-coding-system-for-mime-charset bsubstr)
 117                               (mm-charset-to-coding-system bsubstr)))
 118                           charset)))
 119             (delete-region (point-min) (point-max))
 120             (insert (mm-decode-string text charset))
 121             (save-window-excursion
 122               (save-restriction
 123                 (let ((w3-strict-width width)
 124                       ;; Don't let w3 set the global version of
 125                       ;; this variable.
 126                       (fill-column fill-column)
 127                       (w3-honor-stylesheets nil)
 128                       (w3-delay-image-loads t)
 129                       (url-standalone-mode t))
 130                   (condition-case var
 131                       (w3-region (point-min) (point-max))
 132                     (error
 133                      (delete-region (point-min) (point-max))
 134                      (let ((b (point))
 135                            (charset (mail-content-type-get
 136                                      (mm-handle-type handle) 'charset)))
 137                        (if (or (eq charset 'gnus-decoded)
 138                                (eq mail-parse-charset 'gnus-decoded))
 139                            (save-restriction
 140                              (narrow-to-region (point) (point))
 141                              (mm-insert-part handle)
 142                              (goto-char (point-max)))
 143                          (insert (mm-decode-string (mm-get-part handle)
 144                                                    charset))))
 145                      (message
 146                       "Error while rendering html; showing as text/plain"))))))
 147             (mm-handle-set-undisplayer
 148              handle
 149              `(lambda ()
 150                 (let (buffer-read-only)
 151                   (if (functionp 'remove-specifier)
 152                       (mapcar (lambda (prop)
 153                                 (remove-specifier
 154                                  (face-property 'default prop)
 155                                  (current-buffer)))
 156                               '(background background-pixmap foreground)))
 157                   (delete-region ,(point-min-marker)
 158                                  ,(point-max-marker)))))))))
 159      ((equal type "x-vcard")
 160       (mm-insert-inline
 161        handle
 162        (concat "\n-- \n"
 163                (ignore-errors
 164                  (if (fboundp 'vcard-pretty-print)
 165                      (vcard-pretty-print (mm-get-part handle))
 166                    (vcard-format-string
 167                     (vcard-parse-string (mm-get-part handle)
 168                                         'vcard-standard-filter)))))))
 169      (t
 170       (let ((b (point))
 171             (charset (mail-content-type-get
 172                       (mm-handle-type handle) 'charset)))
 173         (if (or (eq charset 'gnus-decoded)
 174                 ;; This is probably not entirely correct, but
 175                 ;; makes rfc822 parts with embedded multiparts work.
 176                 (eq mail-parse-charset 'gnus-decoded))
 177             (save-restriction
 178               (narrow-to-region (point) (point))
 179               (mm-insert-part handle)
 180               (goto-char (point-max)))
 181           (insert (mm-decode-string (mm-get-part handle) charset)))
 182         (when (and (equal type "plain")
 183                    (equal (cdr (assoc 'format (mm-handle-type handle)))
 184                           "flowed"))
 185           (save-restriction
 186             (narrow-to-region b (point))
 187             (goto-char b)
 188             (fill-flowed)
 189             (goto-char (point-max))))
 190         (save-restriction
 191           (narrow-to-region b (point))
 192           (set-text-properties (point-min) (point-max) nil)
 193           (when (or (equal type "enriched")
 194                     (equal type "richtext"))
 195             (enriched-decode (point-min) (point-max)))
 196           (mm-handle-set-undisplayer
 197            handle
 198            `(lambda ()
 199               (let (buffer-read-only)
 200                 (delete-region ,(point-min-marker)
 201                                ,(point-max-marker)))))))))))
 202
 203 (defun mm-insert-inline (handle text)
 204   "Insert TEXT inline from HANDLE."
 205   (let ((b (point)))
 206     (insert text)
 207     (mm-handle-set-undisplayer
 208      handle
 209      `(lambda ()
 210         (let (buffer-read-only)
 211           (delete-region ,(set-marker (make-marker) b)
 212                          ,(set-marker (make-marker) (point))))))))
 213
 214 (defun mm-inline-audio (handle)
 215   (message "Not implemented"))
 216
 217 (defun mm-view-sound-file ()
 218   (message "Not implemented"))
 219
 220 (defun mm-w3-prepare-buffer ()
 221   (require 'w3)
 222   (let ((url-standalone-mode t)
 223         (w3-honor-stylesheets nil)
 224         (w3-delay-image-loads t))
 225     (w3-prepare-buffer)))
 226
 227 (defun mm-view-message ()
 228   (mm-enable-multibyte)
 229   (let (handles)
 230     (let (gnus-article-mime-handles)
 231       ;; Double decode problem may happen.  See mm-inline-message.
 232       (run-hooks 'gnus-article-decode-hook)
 233       (gnus-article-prepare-display)
 234       (setq handles gnus-article-mime-handles))
 235     (when handles
 236       (setq gnus-article-mime-handles
 237             (mm-merge-handles gnus-article-mime-handles handles))))
 238   (fundamental-mode)
 239   (goto-char (point-min)))
 240
 241 (defun mm-inline-message (handle)
 242   (let ((b (point))
 243         (bolp (bolp))
 244         (charset (mail-content-type-get
 245                   (mm-handle-type handle) 'charset))
 246         gnus-displaying-mime handles)
 247     (when (and charset
 248                (stringp charset))
 249       (setq charset (intern (downcase charset)))
 250       (when (eq charset 'us-ascii)
 251         (setq charset nil)))
 252     (save-excursion
 253       (save-restriction
 254         (narrow-to-region b b)
 255         (mm-insert-part handle)
 256         (let (gnus-article-mime-handles
 257               ;; disable prepare hook
 258               gnus-article-prepare-hook
 259               (gnus-newsgroup-charset
 260                (or charset gnus-newsgroup-charset)))
 261           (run-hooks 'gnus-article-decode-hook)
 262           (gnus-article-prepare-display)
 263           (setq handles gnus-article-mime-handles))
 264         (goto-char (point-min))
 265         (unless bolp
 266           (insert "\n"))
 267         (goto-char (point-max))
 268         (unless (bolp)
 269           (insert "\n"))
 270         (insert "----------\n\n")
 271         (when handles
 272           (setq gnus-article-mime-handles
 273                 (mm-merge-handles gnus-article-mime-handles handles)))
 274         (mm-handle-set-undisplayer
 275          handle
 276          `(lambda ()
 277             (let (buffer-read-only)
 278               (if (fboundp 'remove-specifier)
 279                   ;; This is only valid on XEmacs.
 280                   (mapcar (lambda (prop)
 281                             (remove-specifier
 282                              (face-property 'default prop) (current-buffer)))
 283                           '(background background-pixmap foreground)))
 284               (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
 285
 286 (defun mm-display-inline-fontify (handle mode)
 287   (let (text)
 288     ;; XEmacs @#$@ version of font-lock refuses to fully turn itself
 289     ;; on for buffers whose name begins with " ".  That's why we use
 290     ;; save-current-buffer/get-buffer-create rather than
 291     ;; with-temp-buffer.
 292     (save-current-buffer
 293       (set-buffer (generate-new-buffer "*fontification*"))
 294       (unwind-protect
 295           (progn
 296             (buffer-disable-undo)
 297             (mm-insert-part handle)
 298             (funcall mode)
 299             (require 'font-lock)
 300             (let ((font-lock-verbose nil))
 301               ;; I find font-lock a bit too verbose.
 302               (font-lock-fontify-buffer))
 303             ;; By default, XEmacs font-lock uses non-duplicable text
 304             ;; properties.  This code forces all the text properties
 305             ;; to be copied along with the text.
 306             (when (fboundp 'extent-list)
 307               (map-extents (lambda (ext ignored)
 308                              (set-extent-property ext 'duplicable t)
 309                              nil)
 310                            nil nil nil nil nil 'text-prop))
 311             (setq text (buffer-string)))
 312         (kill-buffer (current-buffer))))
 313     (mm-insert-inline handle text)))
 314
 315 ;; Shouldn't these functions check whether the user even wants to use
 316 ;; font-lock?  At least under XEmacs, this fontification is pretty
 317 ;; much unconditional.  Also, it would be nice to change for the size
 318 ;; of the fontified region.
 319
 320 (defun mm-display-patch-inline (handle)
 321   (mm-display-inline-fontify handle 'diff-mode))
 322
 323 (defun mm-display-elisp-inline (handle)
 324   (mm-display-inline-fontify handle 'emacs-lisp-mode))
 325
 326 ;;      id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
 327 ;;          us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 }
 328 (defvar mm-pkcs7-signed-magic
 329   (mm-string-as-unibyte
 330    (apply 'concat
 331           (mapcar 'char-to-string
 332                   (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c
 333                         ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e
 334                         ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48
 335                         ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x02)))))
 336
 337 ;;      id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
 338 ;;          us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 }
 339 (defvar mm-pkcs7-enveloped-magic
 340   (mm-string-as-unibyte
 341    (apply 'concat
 342           (mapcar 'char-to-string
 343                   (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c
 344                         ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e
 345                         ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48
 346                         ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x03)))))
 347
 348 (defun mm-view-pkcs7-get-type (handle)
 349   (mm-with-unibyte-buffer
 350     (mm-insert-part handle)
 351     (cond ((looking-at mm-pkcs7-enveloped-magic)
 352            'enveloped)
 353           ((looking-at mm-pkcs7-signed-magic)
 354            'signed)
 355           (t
 356            (error "Could not identify PKCS#7 type")))))
 357
 358 (defun mm-view-pkcs7 (handle)
 359   (case (mm-view-pkcs7-get-type handle)
 360     (enveloped (mm-view-pkcs7-decrypt handle))
 361     (otherwise (error "Unknown or unimplemented PKCS#7 type"))))
 362
 363 (defun mm-view-pkcs7-decrypt (handle)
 364   (insert-buffer (mm-handle-buffer handle))
 365   (goto-char (point-min))
 366   (insert "MIME-Version: 1.0\n")
 367   (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m")
 368   (smime-decrypt-region
 369    (point-min) (point-max)
 370    (if (= (length smime-keys) 1)
 371        (cadar smime-keys)
 372      (smime-get-key-by-email
 373       (completing-read "Decrypt this part with which key? "
 374                        smime-keys nil nil
 375                        (and (listp (car-safe smime-keys))
 376                             (caar smime-keys)))))))
 377
 378 (provide 'mm-view)
 379
 380 ;;; mm-view.el ends here