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