cgit.sxemacs.org Git - gnus/blob - lisp/gnus-html.el

   1 ;;; gnus-html.el --- Render HTML in a buffer.
   2
   3 ;; Copyright (C) 2010-2011  Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: html, web
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; The idea is to provide a simple, fast and pretty minimal way to
  26 ;; render HTML (including links and images) in a buffer, based on an
  27 ;; external HTML renderer (i.e., w3m).
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl))
  32
  33 (require 'gnus-art)
  34 (eval-when-compile (require 'mm-decode))
  35
  36 (require 'mm-url)
  37 (require 'url)
  38 (require 'url-cache)
  39 (require 'xml)
  40 (require 'browse-url)
  41 (require 'mm-util)
  42 (eval-and-compile (unless (featurep 'xemacs) (require 'help-fns)))
  43
  44 (defcustom gnus-html-image-cache-ttl (days-to-time 7)
  45   "Time used to determine if we should use images from the cache."
  46   :version "24.1"
  47   :group 'gnus-art
  48   :type 'integer)
  49
  50 (defcustom gnus-html-image-automatic-caching t
  51   "Whether automatically cache retrieve images."
  52   :version "24.1"
  53   :group 'gnus-art
  54   :type 'boolean)
  55
  56 (defcustom gnus-html-frame-width 70
  57   "What width to use when rendering HTML."
  58   :version "24.1"
  59   :group 'gnus-art
  60   :type 'integer)
  61
  62 (defcustom gnus-max-image-proportion 0.9
  63   "How big pictures displayed are in relation to the window they're in.
  64 A value of 0.7 means that they are allowed to take up 70% of the
  65 width and height of the window.  If they are larger than this,
  66 and Emacs supports it, then the images will be rescaled down to
  67 fit these criteria."
  68   :version "24.1"
  69   :group 'gnus-art
  70   :type 'float)
  71
  72 (defvar gnus-html-image-map
  73   (let ((map (make-sparse-keymap)))
  74     (define-key map "u" 'gnus-article-copy-string)
  75     (define-key map "i" 'gnus-html-insert-image)
  76     (define-key map "v" 'gnus-html-browse-url)
  77     map))
  78
  79 (defvar gnus-html-displayed-image-map
  80   (let ((map (make-sparse-keymap)))
  81     (define-key map "a" 'gnus-html-show-alt-text)
  82     (define-key map "i" 'gnus-html-browse-image)
  83     (define-key map "\r" 'gnus-html-browse-url)
  84     (define-key map "u" 'gnus-article-copy-string)
  85     (define-key map [tab] 'widget-forward)
  86     map))
  87
  88 (eval-and-compile
  89   (defalias 'gnus-html-encode-url-chars
  90     (if (fboundp 'browse-url-url-encode-chars)
  91         'browse-url-url-encode-chars
  92       (lambda (text chars)
  93         "URL-encode the chars in TEXT that match CHARS.
  94 CHARS is a regexp-like character alternative (e.g., \"[)$]\")."
  95         (let ((encoded-text (copy-sequence text))
  96               (s 0))
  97           (while (setq s (string-match chars encoded-text s))
  98             (setq encoded-text
  99                   (replace-match (format "%%%x"
 100                                          (string-to-char
 101                                           (match-string 0 encoded-text)))
 102                                  t t encoded-text)
 103                   s (1+ s)))
 104           encoded-text)))))
 105
 106 (defun gnus-html-encode-url (url)
 107   "Encode URL."
 108   (gnus-html-encode-url-chars url "[)$ ]"))
 109
 110 (defun gnus-html-cache-expired (url ttl)
 111   "Check if URL is cached for more than TTL."
 112   (cond (url-standalone-mode
 113          (not (file-exists-p (url-cache-create-filename url))))
 114         (t (let ((cache-time (url-is-cached url)))
 115              (if cache-time
 116                  (time-less-p
 117                   (time-add
 118                    cache-time
 119                    ttl)
 120                   (current-time))
 121                t)))))
 122
 123 ;;;###autoload
 124 (defun gnus-article-html (&optional handle)
 125   (let ((article-buffer (current-buffer)))
 126     (unless handle
 127       (setq handle (mm-dissect-buffer t)))
 128     (save-restriction
 129       (narrow-to-region (point) (point))
 130       (save-excursion
 131         (mm-with-part handle
 132           (let* ((coding-system-for-read 'utf-8)
 133                  (coding-system-for-write 'utf-8)
 134                  (default-process-coding-system
 135                    (cons coding-system-for-read coding-system-for-write))
 136                  (charset (mail-content-type-get (mm-handle-type handle)
 137                                                  'charset)))
 138             (when (and charset
 139                        (setq charset (mm-charset-to-coding-system charset))
 140                        (not (eq charset 'ascii)))
 141               (insert (prog1
 142                           (mm-decode-coding-string (buffer-string) charset)
 143                         (erase-buffer)
 144                         (mm-enable-multibyte))))
 145             (call-process-region (point-min) (point-max)
 146                                  "w3m"
 147                                  nil article-buffer nil
 148                                  "-halfdump"
 149                                  "-no-cookie"
 150                                  "-I" "UTF-8"
 151                                  "-O" "UTF-8"
 152                                  "-o" "ext_halfdump=1"
 153                                  "-o" "display_ins_del=2"
 154                                  "-o" "pre_conv=1"
 155                                  "-t" (format "%s" tab-width)
 156                                  "-cols" (format "%s" gnus-html-frame-width)
 157                                  "-o" "display_image=on"
 158                                  "-T" "text/html"))))
 159       (gnus-html-wash-tags))))
 160
 161 (defvar gnus-article-mouse-face)
 162
 163 (defun gnus-html-pre-wash ()
 164   (goto-char (point-min))
 165   (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t)
 166     (replace-match "" t t))
 167   (goto-char (point-min))
 168   (while (re-search-forward "<a name[^\n>]+>" nil t)
 169     (replace-match "" t t)))