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