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-mode-map nil
 157   "Local keymap for inlined text/html part rendered by emacs-w3m.  It will
 158 be slightly different from `w3m-mode-map' to use in the article buffer.")
 159
 160 (defvar mm-w3m-mode-command-alist
 161   '((backward-char)
 162     (describe-mode)
 163     (forward-char)
 164     (goto-line)
 165     (next-line)
 166     (previous-line)
 167     (w3m-antenna)
 168     (w3m-antenna-add-current-url)
 169     (w3m-bookmark-add-current-url)
 170     (w3m-bookmark-add-this-url)
 171     (w3m-bookmark-view)
 172     (w3m-close-window)
 173     (w3m-copy-buffer)
 174     (w3m-delete-buffer)
 175     (w3m-dtree)
 176     (w3m-edit-current-url)
 177     (w3m-edit-this-url)
 178     (w3m-gohome)
 179     (w3m-goto-url)
 180     (w3m-goto-url-new-session)
 181     (w3m-history)
 182     (w3m-history-restore-position)
 183     (w3m-history-store-position)
 184     (w3m-namazu)
 185     (w3m-next-buffer)
 186     (w3m-previous-buffer)
 187     (w3m-quit)
 188     (w3m-redisplay-with-charset)
 189     (w3m-reload-this-page)
 190     (w3m-scroll-down-or-previous-url)
 191     (w3m-scroll-up-or-next-url)
 192     (w3m-search)
 193     (w3m-select-buffer)
 194     (w3m-switch-buffer)
 195     (w3m-view-header)
 196     (w3m-view-parent-page)
 197     (w3m-view-previous-page)
 198     (w3m-view-source)
 199     (w3m-weather))
 200   "Alist of commands to use for emacs-w3m in the article buffer.  Each
 201 element looks like (FROM-COMMAND . TO-COMMAND); FROM-COMMAND should be
 202 registered in `w3m-mode-map' which will be substituted by TO-COMMAND
 203 in `mm-w3m-mode-map'.  If TO-COMMAND is nil, an article command key
 204 will not be substituted.")
 205
 206 (defvar mm-w3m-setup nil
 207   "Whether gnus-article-mode has been setup to use emacs-w3m.")
 208
 209 (defun mm-setup-w3m ()
 210   "Setup gnus-article-mode to use emacs-w3m."
 211   (unless mm-w3m-setup
 212     (require 'w3m)
 213     (unless mm-w3m-mode-map
 214       (setq mm-w3m-mode-map (copy-keymap w3m-mode-map))
 215       (dolist (def mm-w3m-mode-command-alist)
 216         (condition-case nil
 217             (substitute-key-definition (car def) (cdr def) mm-w3m-mode-map)
 218           (error))))
 219     (unless (assq 'gnus-article-mode w3m-cid-retrieve-function-alist)
 220       (push (cons 'gnus-article-mode 'mm-w3m-cid-retrieve)
 221             w3m-cid-retrieve-function-alist))
 222     (setq mm-w3m-setup t)))
 223
 224 (defun mm-w3m-cid-retrieve (url &rest args)
 225   "Insert a content pointed by URL if it has the cid: scheme."
 226   (when (string-match "\\`cid:" url)
 227     (setq url (concat "<" (substring url (match-end 0)) ">"))
 228     (catch 'found-handle
 229       (dolist (handle (with-current-buffer w3m-current-buffer
 230                         gnus-article-mime-handles))
 231         (when (and (listp handle)
 232                    (equal url (mm-handle-id handle)))
 233           (mm-insert-part handle)
 234           (throw 'found-handle (mm-handle-media-type handle)))))))
 235
 236 (defun mm-inline-text-html-render-with-w3m (handle)
 237   "Render a text/html part using emacs-w3m."
 238   (mm-setup-w3m)
 239   (let ((text (mm-get-part handle))
 240         (b (point))
 241         (charset (mail-content-type-get (mm-handle-type handle) 'charset)))
 242     (save-excursion
 243       (insert text)
 244       (save-restriction
 245         (narrow-to-region b (point))
 246         (goto-char (point-min))
 247         (when (re-search-forward w3m-meta-content-type-charset-regexp nil t)
 248           (setq charset (or (w3m-charset-to-coding-system (match-string 2))
 249                             charset)))
 250         (when charset
 251           (delete-region (point-min) (point-max))
 252           (insert (mm-decode-string text charset)))
 253         (let ((w3m-safe-url-regexp "\\`cid:")
 254               (w3m-display-inline-images mm-inline-text-html-with-images))
 255           (w3m-region (point-min) (point-max)))
 256         (when mm-inline-text-html-with-w3m-keymap
 257           (add-text-properties
 258            (point-min) (point-max)
 259            (append '(mm-inline-text-html-with-w3m t)
 260                    (gnus-local-map-property mm-w3m-mode-map)))))
 261       (mm-handle-set-undisplayer
 262        handle
 263        `(lambda ()
 264           (let (buffer-read-only)
 265             (if (functionp 'remove-specifier)
 266                 (mapcar (lambda (prop)
 267                           (remove-specifier
 268                            (face-property 'default prop)
 269                            (current-buffer)))
 270                         '(background background-pixmap foreground)))
 271             (delete-region ,(point-min-marker)
 272                            ,(point-max-marker))))))))
 273
 274 (defun mm-inline-text (handle)
 275   (let ((type (mm-handle-media-subtype handle))
 276         buffer-read-only)
 277     (cond
 278      ((equal type "html")
 279       (funcall mm-inline-text-html-renderer handle))
 280      ((equal type "x-vcard")
 281       (mm-insert-inline
 282        handle
 283        (concat "\n-- \n"
 284                (ignore-errors
 285                  (if (fboundp 'vcard-pretty-print)
 286                      (vcard-pretty-print (mm-get-part handle))
 287                    (vcard-format-string
 288                     (vcard-parse-string (mm-get-part handle)
 289                                         'vcard-standard-filter)))))))
 290      (t
 291       (let ((b (point))
 292             (charset (mail-content-type-get
 293                       (mm-handle-type handle) 'charset)))
 294         (if (or (eq charset 'gnus-decoded)
 295                 ;; This is probably not entirely correct, but
 296                 ;; makes rfc822 parts with embedded multiparts work.
 297                 (eq mail-parse-charset 'gnus-decoded))
 298             (save-restriction
 299               (narrow-to-region (point) (point))
 300               (mm-insert-part handle)
 301               (goto-char (point-max)))
 302           (insert (mm-decode-string (mm-get-part handle) charset)))
 303         (when (and (equal type "plain")
 304                    (equal (cdr (assoc 'format (mm-handle-type handle)))
 305                           "flowed"))
 306           (save-restriction
 307             (narrow-to-region b (point))
 308             (goto-char b)
 309             (fill-flowed)
 310             (goto-char (point-max))))
 311         (save-restriction
 312           (narrow-to-region b (point))
 313           (set-text-properties (point-min) (point-max) nil)
 314           (when (or (equal type "enriched")
 315                     (equal type "richtext"))
 316             (enriched-decode (point-min) (point-max)))
 317           (mm-handle-set-undisplayer
 318            handle
 319            `(lambda ()
 320               (let (buffer-read-only)
 321                 (delete-region ,(point-min-marker)
 322                                ,(point-max-marker)))))))))))
 323
 324 (defun mm-insert-inline (handle text)
 325   "Insert TEXT inline from HANDLE."
 326   (let ((b (point)))
 327     (insert text)
 328     (mm-handle-set-undisplayer
 329      handle
 330      `(lambda ()
 331         (let (buffer-read-only)
 332           (delete-region ,(set-marker (make-marker) b)
 333                          ,(set-marker (make-marker) (point))))))))
 334
 335 (defun mm-inline-audio (handle)
 336   (message "Not implemented"))
 337
 338 (defun mm-view-sound-file ()
 339   (message "Not implemented"))
 340
 341 (defun mm-w3-prepare-buffer ()
 342   (require 'w3)
 343   (let ((url-standalone-mode t)
 344         (w3-honor-stylesheets nil)
 345         (w3-delay-image-loads t))
 346     (w3-prepare-buffer)))
 347
 348 (defun mm-view-message ()
 349   (mm-enable-multibyte)
 350   (let (handles)
 351     (let (gnus-article-mime-handles)
 352       ;; Double decode problem may happen.  See mm-inline-message.
 353       (run-hooks 'gnus-article-decode-hook)
 354       (gnus-article-prepare-display)
 355       (setq handles gnus-article-mime-handles))
 356     (when handles
 357       (setq gnus-article-mime-handles
 358             (mm-merge-handles gnus-article-mime-handles handles))))
 359   (fundamental-mode)
 360   (goto-char (point-min)))
 361
 362 (defun mm-inline-message (handle)
 363   (let ((b (point))
 364         (bolp (bolp))
 365         (charset (mail-content-type-get
 366                   (mm-handle-type handle) 'charset))
 367         gnus-displaying-mime handles)
 368     (when (and charset
 369                (stringp charset))
 370       (setq charset (intern (downcase charset)))
 371       (when (eq charset 'us-ascii)
 372         (setq charset nil)))
 373     (save-excursion
 374       (save-restriction
 375         (narrow-to-region b b)
 376         (mm-insert-part handle)
 377         (let (gnus-article-mime-handles
 378               ;; disable prepare hook
 379               gnus-article-prepare-hook
 380               (gnus-newsgroup-charset
 381                (or charset gnus-newsgroup-charset)))
 382           (run-hooks 'gnus-article-decode-hook)
 383           (gnus-article-prepare-display)
 384           (setq handles gnus-article-mime-handles))
 385         (goto-char (point-min))
 386         (unless bolp
 387           (insert "\n"))
 388         (goto-char (point-max))
 389         (unless (bolp)
 390           (insert "\n"))
 391         (insert "----------\n\n")
 392         (when handles
 393           (setq gnus-article-mime-handles
 394                 (mm-merge-handles gnus-article-mime-handles handles)))
 395         (mm-handle-set-undisplayer
 396          handle
 397          `(lambda ()
 398             (let (buffer-read-only)
 399               (if (fboundp 'remove-specifier)
 400                   ;; This is only valid on XEmacs.
 401                   (mapcar (lambda (prop)
 402                             (remove-specifier
 403                              (face-property 'default prop) (current-buffer)))
 404                           '(background background-pixmap foreground)))
 405               (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
 406
 407 (defun mm-display-inline-fontify (handle mode)
 408   (let (text)
 409     ;; XEmacs @#$@ version of font-lock refuses to fully turn itself
 410     ;; on for buffers whose name begins with " ".  That's why we use
 411     ;; save-current-buffer/get-buffer-create rather than
 412     ;; with-temp-buffer.
 413     (save-current-buffer
 414       (set-buffer (generate-new-buffer "*fontification*"))
 415       (unwind-protect
 416           (progn
 417             (buffer-disable-undo)
 418             (mm-insert-part handle)
 419             (funcall mode)
 420             (require 'font-lock)
 421             (let ((font-lock-verbose nil))
 422               ;; I find font-lock a bit too verbose.
 423               (font-lock-fontify-buffer))
 424             ;; By default, XEmacs font-lock uses non-duplicable text
 425             ;; properties.  This code forces all the text properties
 426             ;; to be copied along with the text.
 427             (when (fboundp 'extent-list)
 428               (map-extents (lambda (ext ignored)
 429                              (set-extent-property ext 'duplicable t)
 430                              nil)
 431                            nil nil nil nil nil 'text-prop))
 432             (setq text (buffer-string)))
 433         (kill-buffer (current-buffer))))
 434     (mm-insert-inline handle text)))
 435
 436 ;; Shouldn't these functions check whether the user even wants to use
 437 ;; font-lock?  At least under XEmacs, this fontification is pretty
 438 ;; much unconditional.  Also, it would be nice to change for the size
 439 ;; of the fontified region.
 440
 441 (defun mm-display-patch-inline (handle)
 442   (mm-display-inline-fontify handle 'diff-mode))
 443
 444 (defun mm-display-elisp-inline (handle)
 445   (mm-display-inline-fontify handle 'emacs-lisp-mode))
 446
 447 ;;      id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
 448 ;;          us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 }
 449 (defvar mm-pkcs7-signed-magic
 450   (mm-string-as-unibyte
 451    (apply 'concat
 452           (mapcar 'char-to-string
 453                   (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c
 454                         ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e
 455                         ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48
 456                         ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x02)))))
 457
 458 ;;      id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
 459 ;;          us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 }
 460 (defvar mm-pkcs7-enveloped-magic
 461   (mm-string-as-unibyte
 462    (apply 'concat
 463           (mapcar 'char-to-string
 464                   (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c
 465                         ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e
 466                         ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48
 467                         ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x03)))))
 468
 469 (defun mm-view-pkcs7-get-type (handle)
 470   (mm-with-unibyte-buffer
 471     (mm-insert-part handle)
 472     (cond ((looking-at mm-pkcs7-enveloped-magic)
 473            'enveloped)
 474           ((looking-at mm-pkcs7-signed-magic)
 475            'signed)
 476           (t
 477            (error "Could not identify PKCS#7 type")))))
 478
 479 (defun mm-view-pkcs7 (handle)
 480   (case (mm-view-pkcs7-get-type handle)
 481     (enveloped (mm-view-pkcs7-decrypt handle))
 482     (otherwise (error "Unknown or unimplemented PKCS#7 type"))))
 483
 484 (defun mm-view-pkcs7-decrypt (handle)
 485   (insert-buffer (mm-handle-buffer handle))
 486   (goto-char (point-min))
 487   (insert "MIME-Version: 1.0\n")
 488   (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m")
 489   (smime-decrypt-region
 490    (point-min) (point-max)
 491    (if (= (length smime-keys) 1)
 492        (cadar smime-keys)
 493      (smime-get-key-by-email
 494       (completing-read "Decrypt this part with which key? "
 495                        smime-keys nil nil
 496                        (and (listp (car-safe smime-keys))
 497                             (caar smime-keys)))))))
 498
 499 (provide 'mm-view)
 500
 501 ;;; mm-view.el ends here