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