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, 2003 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   (autoload 'html2text "html2text")
  38   (unless (fboundp 'diff-mode)
  39     (autoload 'diff-mode "diff-mode" "" t nil)))
  40
  41 (defvar mm-text-html-renderer-alist
  42   '((w3  . mm-inline-text-html-render-with-w3)
  43     (w3m . mm-inline-text-html-render-with-w3m)
  44     (w3m-standalone mm-inline-render-with-stdin nil
  45                     "w3m" "-dump" "-T" "text/html")
  46     (links mm-inline-render-with-file
  47            mm-links-remove-leading-blank
  48            "links" "-dump" file)
  49     (lynx  mm-inline-render-with-stdin nil
  50            "lynx" "-dump" "-force_html" "-stdin" "-nolist")
  51     (html2text  mm-inline-render-with-function html2text))
  52   "The attributes of renderer types for text/html.")
  53
  54 (defvar mm-text-html-washer-alist
  55   '((w3  . gnus-article-wash-html-with-w3)
  56     (w3m . gnus-article-wash-html-with-w3m)
  57     (w3m-standalone mm-inline-wash-with-stdin nil
  58                     "w3m" "-dump" "-T" "text/html")
  59     (links mm-inline-wash-with-file
  60            mm-links-remove-leading-blank
  61            "links" "-dump" file)
  62     (lynx  mm-inline-wash-with-stdin nil
  63            "lynx" "-dump" "-force_html" "-stdin" "-nolist")
  64     (html2text  html2text))
  65   "The attributes of washer types for text/html.")
  66
  67 ;;; Internal variables.
  68
  69 ;;;
  70 ;;; Functions for displaying various formats inline
  71 ;;;
  72
  73 (defun mm-inline-image-emacs (handle)
  74   (let ((b (point-marker))
  75         buffer-read-only)
  76     (put-image (mm-get-image handle) b)
  77     (insert "\n\n")
  78     (mm-handle-set-undisplayer
  79      handle
  80      `(lambda ()
  81         (let ((b ,b)
  82               buffer-read-only)
  83           (remove-images b b)
  84           (delete-region b (+ b 2)))))))
  85
  86 (defun mm-inline-image-xemacs (handle)
  87   (insert "\n\n")
  88   (forward-char -2)
  89   (let ((annot (make-annotation (mm-get-image handle) nil 'text))
  90         buffer-read-only)
  91     (mm-handle-set-undisplayer
  92      handle
  93      `(lambda ()
  94         (let ((b ,(point-marker))
  95               buffer-read-only)
  96           (delete-annotation ,annot)
  97           (delete-region (- b 2) b))))
  98     (set-extent-property annot 'mm t)
  99     (set-extent-property annot 'duplicable t)))
 100
 101 (eval-and-compile
 102   (if (featurep 'xemacs)
 103       (defalias 'mm-inline-image 'mm-inline-image-xemacs)
 104     (defalias 'mm-inline-image 'mm-inline-image-emacs)))
 105
 106 (defvar mm-w3-setup nil)
 107 (defun mm-setup-w3 ()
 108   (unless mm-w3-setup
 109     (require 'w3)
 110     (w3-do-setup)
 111     (require 'url)
 112     (require 'w3-vars)
 113     (require 'url-vars)
 114     (setq mm-w3-setup t)))
 115
 116 (defun mm-inline-text-html-render-with-w3 (handle)
 117   (mm-setup-w3)
 118   (let ((text (mm-get-part handle))
 119         (b (point))
 120         (url-standalone-mode t)
 121         (url-gateway-unplugged t)
 122         (w3-honor-stylesheets nil)
 123         (url-current-object
 124          (url-generic-parse-url (format "cid:%s" (mm-handle-id handle))))
 125         (width (window-width))
 126         (charset (mail-content-type-get
 127                   (mm-handle-type handle) 'charset)))
 128     (save-excursion
 129       (insert text)
 130       (save-restriction
 131         (narrow-to-region b (point))
 132         (goto-char (point-min))
 133         (if (or (and (boundp 'w3-meta-content-type-charset-regexp)
 134                      (re-search-forward
 135                       w3-meta-content-type-charset-regexp nil t))
 136                 (and (boundp 'w3-meta-charset-content-type-regexp)
 137                      (re-search-forward
 138                       w3-meta-charset-content-type-regexp nil t)))
 139             (setq charset
 140                   (or (let ((bsubstr (buffer-substring-no-properties
 141                                       (match-beginning 2)
 142                                       (match-end 2))))
 143                         (if (fboundp 'w3-coding-system-for-mime-charset)
 144                             (w3-coding-system-for-mime-charset bsubstr)
 145                           (mm-charset-to-coding-system bsubstr)))
 146                       charset)))
 147         (delete-region (point-min) (point-max))
 148         (insert (mm-decode-string text charset))
 149         (save-window-excursion
 150           (save-restriction
 151             (let ((w3-strict-width width)
 152                   ;; Don't let w3 set the global version of
 153                   ;; this variable.
 154                   (fill-column fill-column))
 155               (if (or debug-on-error debug-on-quit)
 156                   (w3-region (point-min) (point-max))
 157                 (condition-case ()
 158                     (w3-region (point-min) (point-max))
 159                   (error
 160                    (delete-region (point-min) (point-max))
 161                    (let ((b (point))
 162                          (charset (mail-content-type-get
 163                                    (mm-handle-type handle) 'charset)))
 164                      (if (or (eq charset 'gnus-decoded)
 165                              (eq mail-parse-charset 'gnus-decoded))
 166                        (save-restriction
 167                          (narrow-to-region (point) (point))
 168                          (mm-insert-part handle)
 169                          (goto-char (point-max)))
 170                        (insert (mm-decode-string (mm-get-part handle)
 171                                                  charset))))
 172                    (message
 173                     "Error while rendering html; showing as text/plain")))))))
 174         (mm-handle-set-undisplayer
 175          handle
 176          `(lambda ()
 177             (let (buffer-read-only)
 178               (if (functionp 'remove-specifier)
 179                   (mapcar (lambda (prop)
 180                             (remove-specifier
 181                              (face-property 'default prop)
 182                              (current-buffer)))
 183                           '(background background-pixmap foreground)))
 184               (delete-region ,(point-min-marker)
 185                              ,(point-max-marker)))))))))
 186
 187 (defvar mm-w3m-setup nil
 188   "Whether gnus-article-mode has been setup to use emacs-w3m.")
 189
 190 (defun mm-setup-w3m ()
 191   "Setup gnus-article-mode to use emacs-w3m."
 192   (unless mm-w3m-setup
 193     (require 'w3m)
 194     (unless (assq 'gnus-article-mode w3m-cid-retrieve-function-alist)
 195       (push (cons 'gnus-article-mode 'mm-w3m-cid-retrieve)
 196             w3m-cid-retrieve-function-alist))
 197     (setq mm-w3m-setup t))
 198   (setq w3m-display-inline-images mm-inline-text-html-with-images))
 199
 200 (defun mm-w3m-cid-retrieve-1 (url handle)
 201   (if (mm-multiple-handles handle)
 202       (dolist (elem handle)
 203         (mm-w3m-cid-retrieve-1 url elem))
 204     (when (and (listp handle)
 205                (equal url (mm-handle-id handle)))
 206       (mm-insert-part handle)
 207       (throw 'found-handle (mm-handle-media-type handle)))))
 208
 209 (defun mm-w3m-cid-retrieve (url &rest args)
 210   "Insert a content pointed by URL if it has the cid: scheme."
 211   (when (string-match "\\`cid:" url)
 212     (catch 'found-handle
 213       (mm-w3m-cid-retrieve-1 (concat "<" (substring url (match-end 0)) ">")
 214                              (with-current-buffer w3m-current-buffer
 215                                gnus-article-mime-handles)))))
 216
 217 (defun mm-inline-text-html-render-with-w3m (handle)
 218   "Render a text/html part using emacs-w3m."
 219   (mm-setup-w3m)
 220   (let ((text (mm-get-part handle))
 221         (b (point))
 222         (charset (mail-content-type-get (mm-handle-type handle) 'charset)))
 223     (save-excursion
 224       (insert text)
 225       (save-restriction
 226         (narrow-to-region b (point))
 227         (goto-char (point-min))
 228         (when (re-search-forward w3m-meta-content-type-charset-regexp nil t)
 229           (setq charset (or (w3m-charset-to-coding-system (match-string 2))
 230                             charset)))
 231         (when charset
 232           (delete-region (point-min) (point-max))
 233           (insert (mm-decode-string text charset)))
 234         (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
 235               w3m-force-redisplay)
 236           (w3m-region (point-min) (point-max)))
 237         (when (and mm-inline-text-html-with-w3m-keymap
 238                    (boundp 'w3m-minor-mode-map)
 239                    w3m-minor-mode-map)
 240           (add-text-properties
 241            (point-min) (point-max)
 242            (list 'keymap w3m-minor-mode-map
 243                  ;; Put the mark meaning this part was rendered by emacs-w3m.
 244                  'mm-inline-text-html-with-w3m t))))
 245       (mm-handle-set-undisplayer
 246        handle
 247        `(lambda ()
 248           (let (buffer-read-only)
 249             (if (functionp 'remove-specifier)
 250                 (mapcar (lambda (prop)
 251                           (remove-specifier
 252                            (face-property 'default prop)
 253                            (current-buffer)))
 254                         '(background background-pixmap foreground)))
 255             (delete-region ,(point-min-marker)
 256                            ,(point-max-marker))))))))
 257
 258 (defun mm-links-remove-leading-blank ()
 259   ;; Delete the annoying three spaces preceding each line of links
 260   ;; output.
 261   (goto-char (point-min))
 262   (while (re-search-forward "^   " nil t)
 263     (delete-region (match-beginning 0) (match-end 0))))
 264
 265 (defun mm-inline-wash-with-file (post-func cmd &rest args)
 266   (let ((file (mm-make-temp-file
 267                (expand-file-name "mm" mm-tmp-directory))))
 268     (let ((coding-system-for-write 'binary))
 269       (write-region (point-min) (point-max) file nil 'silent))
 270     (delete-region (point-min) (point-max))
 271     (unwind-protect
 272         (apply 'call-process cmd nil t nil (mapcar 'eval args))
 273       (delete-file file))
 274     (and post-func (funcall post-func))))
 275
 276 (defun mm-inline-wash-with-stdin (post-func cmd &rest args)
 277   (let ((coding-system-for-write 'binary))
 278     (apply 'call-process-region (point-min) (point-max)
 279            cmd t t nil args))
 280   (and post-func (funcall post-func)))
 281
 282 (defun mm-inline-render-with-file (handle post-func cmd &rest args)
 283   (let ((source (mm-get-part handle)))
 284     (mm-insert-inline
 285      handle
 286      (mm-with-unibyte-buffer
 287        (insert source)
 288        (apply 'mm-inline-wash-with-file post-func cmd args)
 289        (buffer-string)))))
 290
 291 (defun mm-inline-render-with-stdin (handle post-func cmd &rest args)
 292   (let ((source (mm-get-part handle)))
 293     (mm-insert-inline
 294      handle
 295      (mm-with-unibyte-buffer
 296        (insert source)
 297        (apply 'mm-inline-wash-with-stdin post-func cmd args)
 298        (buffer-string)))))
 299
 300 (defun mm-inline-render-with-function (handle func &rest args)
 301   (let ((source (mm-get-part handle)))
 302     (mm-insert-inline
 303      handle
 304      (mm-with-unibyte-buffer
 305        (insert source)
 306        (apply func args)
 307        (buffer-string)))))
 308
 309 (defun mm-inline-text-html (handle)
 310   (let* ((func (or mm-inline-text-html-renderer mm-text-html-renderer))
 311          (entry (assq func mm-text-html-renderer-alist))
 312          buffer-read-only)
 313     (if entry
 314         (setq func (cdr entry)))
 315     (cond
 316      ((functionp func)
 317       (funcall func handle))
 318      (t
 319       (apply (car func) handle (cdr func))))))
 320
 321 (defun mm-inline-text-vcard (handle)
 322   (let (buffer-read-only)
 323     (mm-insert-inline
 324      handle
 325      (concat "\n-- \n"
 326              (ignore-errors
 327                (if (fboundp 'vcard-pretty-print)
 328                    (vcard-pretty-print (mm-get-part handle))
 329                  (vcard-format-string
 330                   (vcard-parse-string (mm-get-part handle)
 331                                       'vcard-standard-filter))))))))
 332
 333 (defun mm-inline-text (handle)
 334   (let ((b (point))
 335         (type (mm-handle-media-subtype handle))
 336         (charset (mail-content-type-get
 337                   (mm-handle-type handle) 'charset))
 338         buffer-read-only)
 339     (if (or (eq charset 'gnus-decoded)
 340             ;; This is probably not entirely correct, but
 341             ;; makes rfc822 parts with embedded multiparts work.
 342             (eq mail-parse-charset 'gnus-decoded))
 343         (save-restriction
 344           (narrow-to-region (point) (point))
 345           (mm-insert-part handle)
 346           (goto-char (point-max)))
 347       (insert (mm-decode-string (mm-get-part handle) charset)))
 348     (when (and (equal type "plain")
 349                (equal (cdr (assoc 'format (mm-handle-type handle)))
 350                       "flowed"))
 351       (save-restriction
 352         (narrow-to-region b (point))
 353         (goto-char b)
 354         (fill-flowed)
 355         (goto-char (point-max))))
 356     (save-restriction
 357       (narrow-to-region b (point))
 358       (set-text-properties (point-min) (point-max) nil)
 359       (when (or (equal type "enriched")
 360                 (equal type "richtext"))
 361         (ignore-errors
 362           (enriched-decode (point-min) (point-max))))
 363       (mm-handle-set-undisplayer
 364        handle
 365        `(lambda ()
 366           (let (buffer-read-only)
 367             (delete-region ,(point-min-marker)
 368                            ,(point-max-marker))))))))
 369
 370 (defun mm-insert-inline (handle text)
 371   "Insert TEXT inline from HANDLE."
 372   (let ((b (point)))
 373     (insert text)
 374     (mm-handle-set-undisplayer
 375      handle
 376      `(lambda ()
 377         (let (buffer-read-only)
 378           (delete-region ,(set-marker (make-marker) b)
 379                          ,(set-marker (make-marker) (point))))))))
 380
 381 (defun mm-inline-audio (handle)
 382   (message "Not implemented"))
 383
 384 (defun mm-view-sound-file ()
 385   (message "Not implemented"))
 386
 387 (defun mm-w3-prepare-buffer ()
 388   (require 'w3)
 389   (let ((url-standalone-mode t)
 390         (url-gateway-unplugged t)
 391         (w3-honor-stylesheets nil))
 392     (w3-prepare-buffer)))
 393
 394 (defun mm-view-message ()
 395   (mm-enable-multibyte)
 396   (let (handles)
 397     (let (gnus-article-mime-handles)
 398       ;; Double decode problem may happen.  See mm-inline-message.
 399       (run-hooks 'gnus-article-decode-hook)
 400       (gnus-article-prepare-display)
 401       (setq handles gnus-article-mime-handles))
 402     (when handles
 403       (setq gnus-article-mime-handles
 404             (mm-merge-handles gnus-article-mime-handles handles))))
 405   (fundamental-mode)
 406   (goto-char (point-min)))
 407
 408 (defun mm-inline-message (handle)
 409   (let ((b (point))
 410         (bolp (bolp))
 411         (charset (mail-content-type-get
 412                   (mm-handle-type handle) 'charset))
 413         gnus-displaying-mime handles)
 414     (when (and charset
 415                (stringp charset))
 416       (setq charset (intern (downcase charset)))
 417       (when (eq charset 'us-ascii)
 418         (setq charset nil)))
 419     (save-excursion
 420       (save-restriction
 421         (narrow-to-region b b)
 422         (mm-insert-part handle)
 423         (let (gnus-article-mime-handles
 424               ;; disable prepare hook
 425               gnus-article-prepare-hook
 426               (gnus-newsgroup-charset
 427                (or charset gnus-newsgroup-charset)))
 428           (let ((gnus-original-article-buffer (mm-handle-buffer handle)))
 429             (run-hooks 'gnus-article-decode-hook))
 430           (gnus-article-prepare-display)
 431           (setq handles gnus-article-mime-handles))
 432         (goto-char (point-min))
 433         (unless bolp
 434           (insert "\n"))
 435         (goto-char (point-max))
 436         (unless (bolp)
 437           (insert "\n"))
 438         (insert "----------\n\n")
 439         (when handles
 440           (setq gnus-article-mime-handles
 441                 (mm-merge-handles gnus-article-mime-handles handles)))
 442         (mm-handle-set-undisplayer
 443          handle
 444          `(lambda ()
 445             (let (buffer-read-only)
 446               (if (fboundp 'remove-specifier)
 447                   ;; This is only valid on XEmacs.
 448                   (mapcar (lambda (prop)
 449                             (remove-specifier
 450                              (face-property 'default prop) (current-buffer)))
 451                           '(background background-pixmap foreground)))
 452               (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
 453
 454 (defun mm-display-inline-fontify (handle mode)
 455   (let (text)
 456     ;; XEmacs @#$@ version of font-lock refuses to fully turn itself
 457     ;; on for buffers whose name begins with " ".  That's why we use
 458     ;; save-current-buffer/get-buffer-create rather than
 459     ;; with-temp-buffer.
 460     (save-current-buffer
 461       (set-buffer (generate-new-buffer "*fontification*"))
 462       (unwind-protect
 463           (progn
 464             (buffer-disable-undo)
 465             (mm-insert-part handle)
 466             (funcall mode)
 467             (require 'font-lock)
 468             (let ((font-lock-verbose nil))
 469               ;; I find font-lock a bit too verbose.
 470               (font-lock-fontify-buffer))
 471             ;; By default, XEmacs font-lock uses non-duplicable text
 472             ;; properties.  This code forces all the text properties
 473             ;; to be copied along with the text.
 474             (when (fboundp 'extent-list)
 475               (map-extents (lambda (ext ignored)
 476                              (set-extent-property ext 'duplicable t)
 477                              nil)
 478                            nil nil nil nil nil 'text-prop))
 479             (setq text (buffer-string)))
 480         (kill-buffer (current-buffer))))
 481     (mm-insert-inline handle text)))
 482
 483 ;; Shouldn't these functions check whether the user even wants to use
 484 ;; font-lock?  At least under XEmacs, this fontification is pretty
 485 ;; much unconditional.  Also, it would be nice to change for the size
 486 ;; of the fontified region.
 487
 488 (defun mm-display-patch-inline (handle)
 489   (mm-display-inline-fontify handle 'diff-mode))
 490
 491 (defun mm-display-elisp-inline (handle)
 492   (mm-display-inline-fontify handle 'emacs-lisp-mode))
 493
 494 ;;      id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
 495 ;;          us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 }
 496 (defvar mm-pkcs7-signed-magic
 497   (mm-string-as-unibyte
 498    (apply 'concat
 499           (mapcar 'char-to-string
 500                   (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c
 501                         ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e
 502                         ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48
 503                         ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x02)))))
 504
 505 ;;      id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2)
 506 ;;          us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 }
 507 (defvar mm-pkcs7-enveloped-magic
 508   (mm-string-as-unibyte
 509    (apply 'concat
 510           (mapcar 'char-to-string
 511                   (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c
 512                         ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e
 513                         ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48
 514                         ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x03)))))
 515
 516 (defun mm-view-pkcs7-get-type (handle)
 517   (mm-with-unibyte-buffer
 518     (mm-insert-part handle)
 519     (cond ((looking-at mm-pkcs7-enveloped-magic)
 520            'enveloped)
 521           ((looking-at mm-pkcs7-signed-magic)
 522            'signed)
 523           (t
 524            (error "Could not identify PKCS#7 type")))))
 525
 526 (defun mm-view-pkcs7 (handle)
 527   (case (mm-view-pkcs7-get-type handle)
 528     (enveloped (mm-view-pkcs7-decrypt handle))
 529     (signed (mm-view-pkcs7-verify handle))
 530     (otherwise (error "Unknown or unimplemented PKCS#7 type"))))
 531
 532 (defun mm-view-pkcs7-verify (handle)
 533   ;; A bogus implementation of PKCS#7. FIXME::
 534   (mm-insert-part handle)
 535   (goto-char (point-min))
 536   (if (search-forward "Content-Type: " nil t)
 537       (delete-region (point-min) (match-beginning 0)))
 538   (goto-char (point-max))
 539   (if (re-search-backward "--\r?\n?" nil t)
 540       (delete-region (match-end 0) (point-max)))
 541   (goto-char (point-min))
 542   (while (search-forward "\r\n" nil t)
 543     (replace-match "\n"))
 544   (message "Verify signed PKCS#7 message is unimplemented.")
 545   (sit-for 1)
 546   t)
 547
 548 (defun mm-view-pkcs7-decrypt (handle)
 549   (insert-buffer-substring (mm-handle-buffer handle))
 550   (goto-char (point-min))
 551   (insert "MIME-Version: 1.0\n")
 552   (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m")
 553   (smime-decrypt-region
 554    (point-min) (point-max)
 555    (if (= (length smime-keys) 1)
 556        (cadar smime-keys)
 557      (smime-get-key-by-email
 558       (completing-read
 559        (concat "Decipher using which key? "
 560                (if smime-keys (concat "(default " (caar smime-keys) ") ")
 561                  ""))
 562        smime-keys nil nil nil nil (car-safe (car-safe smime-keys))))))
 563   (goto-char (point-min))
 564   (while (search-forward "\r\n" nil t)
 565     (replace-match "\n"))
 566   (goto-char (point-min)))
 567
 568 (provide 'mm-view)
 569
 570 ;;; mm-view.el ends here