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,
   3 ;; 2004 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; This file is part of GNU Emacs.
   7
   8 ;; GNU Emacs is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; GNU Emacs is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21 ;; Boston, MA 02111-1307, USA.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28 (require 'mail-parse)
  29 (require 'mailcap)
  30 (require 'mm-bodies)
  31 (require 'mm-decode)
  32
  33 (eval-and-compile
  34   (autoload 'gnus-article-prepare-display "gnus-art")
  35   (autoload 'vcard-parse-string "vcard")
  36   (autoload 'vcard-format-string "vcard")
  37   (autoload 'fill-flowed "flow-fill")
  38   (autoload 'html2text "html2text"))
  39
  40 (defvar mm-text-html-renderer-alist
  41   '((w3  . mm-inline-text-html-render-with-w3)
  42     (w3m . mm-inline-text-html-render-with-w3m)
  43     (w3m-standalone mm-inline-render-with-stdin nil
  44                     "w3m" "-dump" "-T" "text/html")
  45     (links mm-inline-render-with-file
  46            mm-links-remove-leading-blank
  47            "links" "-dump" file)
  48     (lynx  mm-inline-render-with-stdin nil
  49            "lynx" "-dump" "-force_html" "-stdin" "-nolist")
  50     (html2text  mm-inline-render-with-function html2text))
  51   "The attributes of renderer types for text/html.")
  52
  53 (defvar mm-text-html-washer-alist
  54   '((w3  . gnus-article-wash-html-with-w3)
  55     (w3m . gnus-article-wash-html-with-w3m)
  56     (w3m-standalone mm-inline-wash-with-stdin nil
  57                     "w3m" "-dump" "-T" "text/html")
  58     (links mm-inline-wash-with-file
  59            mm-links-remove-leading-blank
  60            "links" "-dump" file)
  61     (lynx  mm-inline-wash-with-stdin nil
  62            "lynx" "-dump" "-force_html" "-stdin" "-nolist")
  63     (html2text  html2text))
  64   "The attributes of washer types for text/html.")
  65
  66 (defcustom mm-fill-flowed t
  67   "If non-nil a format=flowed article will be displayed flowed."
  68   :type 'boolean
  69   :group 'mime-display)
  70
  71 ;;; Internal variables.
  72
  73 ;;;
  74 ;;; Functions for displaying various formats inline
  75 ;;;
  76
  77 (defun mm-inline-image-emacs (handle)
  78   (let ((b (point-marker))
  79         buffer-read-only)
  80     (put-image (mm-get-image handle) b)
  81     (mm-handle-set-undisplayer
  82      handle
  83      `(lambda ()
  84         (let ((b ,b)
  85               buffer-read-only)
  86           (remove-images b b)
  87           (delete-region b (+ b 2)))))))
  88
  89 (defun mm-inline-image-xemacs (handle)
  90   (insert "\n\n")
  91   (forward-char -2)
  92   (let ((annot (make-annotation (mm-get-image handle) nil 'text))
  93         buffer-read-only)
  94     (mm-handle-set-undisplayer
  95      handle
  96      `(lambda ()
  97         (let ((b ,(point-marker))
  98               buffer-read-only)
  99           (delete-annotation ,annot)
 100           (delete-region (- b 2) b))))
 101     (set-extent-property annot 'mm t)
 102     (set-extent-property annot 'duplicable t)))
 103
 104 (eval-and-compile
 105   (if (featurep 'xemacs)
 106       (defalias 'mm-inline-image 'mm-inline-image-xemacs)
 107     (defalias 'mm-inline-image 'mm-inline-image-emacs)))
 108
 109 (defvar mm-w3-setup nil)
 110 (defun mm-setup-w3 ()
 111   (unless mm-w3-setup
 112     (require 'w3)
 113     (w3-do-setup)
 114     (require 'url)
 115     (require 'w3-vars)
 116     (require 'url-vars)
 117     (setq mm-w3-setup t)))
 118
 119 (defun mm-inline-text-html-render-with-w3 (handle)
 120   (mm-setup-w3)
 121   (let ((text (mm-get-part handle))
 122         (b (point))
 123         (url-standalone-mode t)
 124         (url-gateway-unplugged t)
 125         (w3-honor-stylesheets nil)
 126         (url-current-object
 127          (url-generic-parse-url (format "cid:%s" (mm-handle-id handle))))
 128         (width (window-width))
 129         (charset (mail-content-type-get
 130                   (mm-handle-type handle) 'charset)))
 131     (save-excursion
 132       (insert (if charset (mm-decode-string text charset) text))
 133       (save-restriction
 134         (narrow-to-region b (point))
 135         (unless charset
 136           (goto-char (point-min))
 137           (when (or (and (boundp 'w3-meta-content-type-charset-regexp)
 138                          (re-search-forward
 139                           w3-meta-content-type-charset-regexp nil t))
 140                     (and (boundp 'w3-meta-charset-content-type-regexp)
 141                          (re-search-forward
 142                           w3-meta-charset-content-type-regexp nil t)))
 143             (setq charset
 144                   (let ((bsubstr (buffer-substring-no-properties
 145                                   (match-beginning 2)
 146                                   (match-end 2))))
 147                     (if (fboundp 'w3-coding-system-for-mime-charset)
 148                         (w3-coding-system-for-mime-charset bsubstr)
 149                       (mm-charset-to-coding-system bsubstr))))
 150             (delete-region (point-min) (point-max))
 151             (insert (mm-decode-string text charset))))
 152         (save-window-excursion
 153           (save-restriction
 154             (let ((w3-strict-width width)
 155                   ;; Don't let w3 set the global version of
 156                   ;; this variable.
 157                   (fill-column fill-column))
 158               (if (or debug-on-error debug-on-quit)
 159                   (w3-region (point-min) (point-max))
 160                 (condition-case ()
 161                     (w3-region (point-min) (point-max))
 162                   (error
 163                    (delete-region (point-min) (point-max))
 164                    (let ((b (point))
 165                          (charset (mail-content-type-get
 166                                    (mm-handle-type handle) 'charset)))
 167                      (if (or (eq charset 'gnus-decoded)
 168                              (eq mail-parse-charset 'gnus-decoded))
 169                        (save-restriction
 170                          (narrow-to-region (point) (point))
 171                          (mm-insert-part handle)
 172                          (goto-char (point-max)))
 173                        (insert (mm-decode-string (mm-get-part handle)
 174                                                  charset))))
 175                    (message
 176                     "Error while rendering html; showing as text/plain")))))))
 177         (mm-handle-set-undisplayer
 178          handle
 179          `(lambda ()
 180             (let (buffer-read-only)
 181               (if (functionp 'remove-specifier)
 182                   (mapcar (lambda (prop)
 183                             (remove-specifier
 184                              (face-property 'default prop)
 185                              (current-buffer)))
 186                           '(background background-pixmap foreground)))
 187               (delete-region ,(point-min-marker)
 188                              ,(point-max-marker)))))))))
 189
 190 (defvar mm-w3m-setup nil
 191   "Whether gnus-article-mode has been setup to use emacs-w3m.")
 192
 193 (defun mm-setup-w3m ()
 194   "Setup gnus-article-mode to use emacs-w3m."
 195   (unless mm-w3m-setup
 196     (require 'w3m)
 197     (unless (assq 'gnus-article-mode w3m-cid-retrieve-function-alist)
 198       (push (cons 'gnus-article-mode 'mm-w3m-cid-retrieve)
 199             w3m-cid-retrieve-function-alist))
 200     (setq mm-w3m-setup t))
 201   (setq w3m-display-inline-images mm-inline-text-html-with-images))
 202
 203 (defun mm-w3m-cid-retrieve-1 (url handle)
 204   (if (mm-multiple-handles handle)
 205       (dolist (elem handle)
 206         (mm-w3m-cid-retrieve-1 url elem))
 207     (when (and (listp handle)
 208                (equal url (mm-handle-id handle)))
 209       (mm-insert-part handle)
 210       (throw 'found-handle (mm-handle-media-type handle)))))
 211
 212 (defun mm-w3m-cid-retrieve (url &rest args)
 213   "Insert a content pointed by URL if it has the cid: scheme."
 214   (when (string-match "\\`cid:" url)
 215     (catch 'found-handle
 216       (mm-w3m-cid-retrieve-1 (concat "<" (substring url (match-end 0)) ">")
 217                              (with-current-buffer w3m-current-buffer
 218                                gnus-article-mime-handles)))))
 219
 220 (defun mm-inline-text-html-render-with-w3m (handle)
 221   "Render a text/html part using emacs-w3m."
 222   (mm-setup-w3m)
 223   (let ((text (mm-get-part handle))
 224         (b (point))
 225         (charset (mail-content-type-get (mm-handle-type handle) 'charset)))
 226     (save-excursion
 227       (insert (if charset (mm-decode-string text charset) text))
 228       (save-restriction
 229         (narrow-to-region b (point))
 230         (unless charset
 231           (goto-char (point-min))
 232           (when (setq charset (w3m-detect-meta-charset))
 233             (delete-region (point-min) (point-max))
 234             (insert (mm-decode-string text charset))))
 235         (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
 236               w3m-force-redisplay)
 237           (w3m-region (point-min) (point-max) nil charset))
 238         (when (and mm-inline-text-html-with-w3m-keymap
 239                    (boundp 'w3m-minor-mode-map)
 240                    w3m-minor-mode-map)
 241           (add-text-properties
 242            (point-min) (point-max)
 243            (list 'keymap w3m-minor-mode-map
 244                  ;; Put the mark meaning this part was rendered by emacs-w3m.
 245                  'mm-inline-text-html-with-w3m t))))
 246       (mm-handle-set-undisplayer
 247        handle
 248        `(lambda ()
 249           (let (buffer-read-only)
 250             (if (functionp 'remove-specifier)
 251                 (mapcar (lambda (prop)
 252                           (remove-specifier
 253                            (face-property 'default prop)
 254                            (current-buffer)))
 255                         '(background background-pixmap foreground)))
 256             (delete-region ,(point-min-marker)
 257                            ,(point-max-marker))))))))
 258
 259 (defun mm-links-remove-leading-blank ()
 260   ;; Delete the annoying three spaces preceding each line of links
 261   ;; output.
 262   (goto-char (point-min))
 263   (while (re-search-forward "^   " nil t)
 264     (delete-region (match-beginning 0) (match-end 0))))
 265
 266 (defun mm-inline-wash-with-file (post-func cmd &rest args)
 267   (let ((file (mm-make-temp-file
 268                (expand-file-name "mm" mm-tmp-directory))))
 269     (let ((coding-system-for-write 'binary))
 270       (write-region (point-min) (point-max) file nil 'silent))
 271     (delete-region (point-min) (point-max))
 272     (unwind-protect
 273         (apply 'call-process cmd nil t nil (mapcar 'eval args))
 274       (delete-file file))
 275     (and post-func (funcall post-func))))
 276
 277 (defun mm-inline-wash-with-stdin (post-func cmd &rest args)
 278   (let ((coding-system-for-write 'binary))
 279     (apply 'call-process-region (point-min) (point-max)
 280            cmd t t nil args))
 281   (and post-func (funcall post-func)))
 282
 283 (defun mm-inline-render-with-file (handle post-func cmd &rest args)
 284   (let ((source (mm-get-part handle)))
 285     (mm-insert-inline
 286      handle
 287      (mm-with-unibyte-buffer
 288        (insert source)
 289        (apply 'mm-inline-wash-with-file post-func cmd args)
 290        (buffer-string)))))
 291
 292 (defun mm-inline-render-with-stdin (handle post-func cmd &rest args)
 293   (let ((source (mm-get-part handle)))
 294     (mm-insert-inline
 295      handle
 296      (mm-with-unibyte-buffer
 297        (insert source)
 298        (apply 'mm-inline-wash-with-stdin post-func cmd args)
 299        (buffer-string)))))
 300
 301 (defun mm-inline-render-with-function (handle func &rest args)
 302   (let ((source (mm-get-part handle)))
 303     (mm-insert-inline
 304      handle
 305      (mm-with-unibyte-buffer
 306        (insert source)
 307        (apply func args)
 308        (buffer-string)))))
 309
 310 (defun mm-inline-text-html (handle)
 311   (let* ((func (or mm-inline-text-html-renderer mm-text-html-renderer))
 312          (entry (assq func mm-text-html-renderer-alist))
 313          buffer-read-only)
 314     (if entry
 315         (setq func (cdr entry)))
 316     (cond
 317      ((functionp func)
 318       (funcall func handle))
 319      (t
 320       (apply (car func) handle (cdr func))))))
 321
 322 (defun mm-inline-text-vcard (handle)
 323   (let (buffer-read-only)
 324     (mm-insert-inline
 325      handle
 326      (concat "\n-- \n"
 327              (ignore-errors
 328                (if (fboundp 'vcard-pretty-print)
 329                    (vcard-pretty-print (mm-get-part handle))
 330                  (vcard-format-string
 331                   (vcard-parse-string (mm-get-part handle)
 332                                       'vcard-standard-filter))))))))
 333
 334 (defun mm-inline-text (handle)
 335   (let ((b (point))
 336         (type (mm-handle-media-subtype handle))
 337         (charset (mail-content-type-get
 338                   (mm-handle-type handle) 'charset))
 339         buffer-read-only)
 340     (if (or (eq charset 'gnus-decoded)
 341             ;; This is probably not entirely correct, but
 342             ;; makes rfc822 parts with embedded multiparts work.
 343             (eq mail-parse-charset 'gnus-decoded))
 344         (save-restriction
 345           (narrow-to-region (point) (point))