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