cgit.sxemacs.org Git - gnus/blob - lisp/mm-view.el

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