cgit.sxemacs.org Git - gnus/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      ((equal type "x-vcard")
 155       (mm-insert-inline
 156        handle
 157        (concat "\n-- \n"
 158                (ignore-errors
 159                  (if (fboundp 'vcard-pretty-print)
 160                      (vcard-pretty-print (mm-get-part handle))
 161                    (vcard-format-string
 162                     (vcard-parse-string (mm-get-part handle)
 163                                         'vcard-standard-filter)))))))
 164      (t
 165       (let ((b (point))
 166             (charset (mail-content-type-get
 167                       (mm-handle-type handle) 'charset)))
 168         (if (or (eq charset 'gnus-decoded)
 169                 ;; This is probably not entirely correct, but
 170                 ;; makes rfc822 parts with embedded multiparts work.
 171                 (eq mail-parse-charset 'gnus-decoded))
 172             (save-restriction
 173               (narrow-to-region (point) (point))
 174               (mm-insert-part handle)
 175               (goto-char (point-max)))
 176           (insert (mm-decode-string (mm-get-part handle) charset)))
 177         (when (and (equal type "plain")
 178                    (equal (cdr (assoc 'format (mm-handle-type handle)))
 179                           "flowed"))
 180           (save-restriction
 181             (narrow-to-region b (point))
 182             (goto-char b)
 183             (fill-flowed)
 184             (goto-char (point-max))))
 185         (save-restriction
 186           (narrow-to-region b (point))
 187           (set-text-properties (point-min) (point-max) nil)
 188           (when (or (equal type "enriched")
 189                     (equal type "richtext"))
 190             (enriched-decode (point-min) (point-max)))
 191           (mm-handle-set-undisplayer
 192            handle
 193            `(lambda ()
 194               (let (buffer-read-only)
 195                 (delete-region ,(point-min-marker)
 196                                ,(point-max-marker)))))))))))
 197
 198 (defun mm-insert-inline (handle text)
 199   "Insert TEXT inline from HANDLE."
 200   (let ((b (point)))
 201     (insert text)
 202     (mm-handle-set-undisplayer
 203      handle
 204      `(lambda ()
 205         (let (buffer-read-only)
 206           (delete-region ,(set-marker (make-marker) b)
 207                          ,(set-marker (make-marker) (point))))))))
 208
 209 (defun mm-inline-audio (handle)
 210   (message "Not implemented"))
 211
 212 (defun mm-view-sound-file ()
 213   (message "Not implemented"))
 214
 215 (defun mm-w3-prepare-buffer ()
 216   (require 'w3)
 217   (let ((url-standalone-mode t))
 218     (w3-prepare-buffer)))
 219
 220 (defun mm-view-message ()
 221   (mm-enable-multibyte)
 222   (let (handles)
 223     (let (gnus-article-mime-handles)
 224       ;; Double decode problem may happen.  See mm-inline-message.
 225       (run-hooks 'gnus-article-decode-hook)
 226       (gnus-article-prepare-display)
 227       (setq handles gnus-article-mime-handles))
 228     (when handles
 229       (setq gnus-article-mime-handles
 230             (mm-merge-handles gnus-article-mime-handles handles))))
 231   (fundamental-mode)
 232   (goto-char (point-min)))
 233
 234 (defun mm-inline-message (handle)
 235   (let ((b (point))
 236         (bolp (bolp))
 237         (charset (mail-content-type-get
 238                   (mm-handle-type handle) 'charset))
 239         gnus-displaying-mime handles)
 240     (when (and charset
 241                (stringp charset))
 242       (setq charset (intern (downcase charset)))
 243       (when (eq charset 'us-ascii)
 244         (setq charset nil)))
 245     (save-excursion
 246       (save-restriction
 247         (narrow-to-region b b)
 248         (mm-insert-part handle)
 249         (let (gnus-article-mime-handles
 250               ;; disable prepare hook
 251               gnus-article-prepare-hook
 252               (gnus-newsgroup-charset
 253                (or charset gnus-newsgroup-charset)))
 254           (run-hooks 'gnus-article-decode-hook)
 255           (gnus-article-prepare-display)
 256           (setq handles gnus-article-mime-handles))
 257         (goto-char (point-min))
 258         (unless bolp
 259           (insert "\n"))
 260         (goto-char (point-max))
 261         (unless (bolp)
 262           (insert "\n"))
 263         (insert "----------\n\n")
 264         (when handles
 265           (setq gnus-article-mime-handles
 266                 (mm-merge-handles gnus-article-mime-handles handles)))
 267         (mm-handle-set-undisplayer
 268          handle
 269          `(lambda ()
 270             (let (buffer-read-only)
 271               (if (fboundp 'remove-specifier)
 272                   ;; This is only valid on XEmacs.
 273                   (mapcar (lambda (prop)
 274                             (remove-specifier
 275                              (face-property 'default prop) (current-buffer)))
 276                           '(background background-pixmap foreground)))
 277               (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
 278
 279 (defun mm-display-inline-fontify (handle mode)
 280   (let (text)
 281     ;; XEmacs @#$@ version of font-lock refuses to fully turn itself
 282     ;; on for buffers whose name begins with " ".  That's why we use
 283     ;; save-current-buffer/get-buffer-create rather than
 284     ;; with-temp-buffer.
 285     (save-current-buffer
 286       (set-buffer (generate-new-buffer "*fontification*"))
 287       (unwind-protect
 288           (progn
 289             (buffer-disable-undo)
 290             (mm-insert-part handle)
 291             (funcall mode)
 292             (let ((font-lock-verbose nil))
 293               ;; I find font-lock a bit too verbose.
 294               (font-lock-fontify-buffer))
 295             ;; By default, XEmacs font-lock uses non-duplicable text
 296             ;; properties.  This code forces all the text properties
 297             ;; to be copied along with the text.
 298             (when (fboundp 'extent-list)
 299               (map-extents (lambda (ext ignored)
 300                              (set-extent-property ext 'duplicable t)
 301                              nil)
 302                            nil nil nil nil nil 'text-prop))
 303             (setq text (buffer-string)))
 304         (kill-buffer (current-buffer))))
 305     (mm-insert-inline handle text)))
 306
 307 ;; Shouldn't these functions check whether the user even wants to use
 308 ;; font-lock?  At least under XEmacs, this fontification is pretty
 309 ;; much unconditional.  Also, it would be nice to change for the size
 310 ;; of the fontified region.
 311
 312 (defun mm-display-patch-inline (handle)
 313   (mm-display-inline-fontify handle 'diff-mode))
 314
 315 (defun mm-display-elisp-inline (handle)
 316   (mm-display-inline-fontify handle 'emacs-lisp-mode))
 317
 318 ;;      id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
 319 ;;          us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 }
 320 (defvar mm-pkcs7-signed-magic
 321   (mm-string-as-unibyte
 322    (apply 'concat
 323           (mapcar 'char-to-string
 324                   (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c
 325                         ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e
 326                         ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48
 327                         ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x02)))))
 328
 329 ;;      id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
 330 ;;          us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 }
 331 (defvar mm-pkcs7-enveloped-magic
 332   (mm-string-as-unibyte
 333    (apply 'concat
 334           (mapcar 'char-to-string
 335                   (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c
 336                         ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e
 337                         ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48
 338                         ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x03)))))
 339
 340 (defun mm-view-pkcs7-get-type (handle)
 341   (mm-with-unibyte-buffer
 342     (mm-insert-part handle)
 343     (cond ((looking-at mm-pkcs7-enveloped-magic)
 344            'enveloped)
 345           ((looking-at mm-pkcs7-signed-magic)
 346            'signed)
 347           (t
 348            (error "Could not identify PKCS#7 type")))))
 349
 350 (defun mm-view-pkcs7 (handle)
 351   (case (mm-view-pkcs7-get-type handle)
 352     (enveloped (mm-view-pkcs7-decrypt handle))
 353     (otherwise (error "Unknown or unimplemented PKCS#7 type"))))
 354
 355 (defun mm-view-pkcs7-decrypt (handle)
 356   (insert-buffer (mm-handle-buffer handle))
 357   (goto-char (point-min))
 358   (insert "MIME-Version: 1.0\n")
 359   (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m")
 360   (smime-decrypt-region
 361    (point-min) (point-max)
 362    (if (= (length smime-keys) 1)
 363        (cadar smime-keys)
 364      (smime-get-key-by-email
 365       (completing-read "Decrypt this part with which key? "
 366                        smime-keys nil nil
 367                        (and (listp (car-safe smime-keys))
 368                             (caar smime-keys)))))))
 369
 370 (provide 'mm-view)
 371
 372 ;;; mm-view.el ends here