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