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

   1 ;;; gnus-html.el --- Quoted-Printable functions
   2
   3 ;; Copyright (C) 2010  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 (require 'mm-url)
  32
  33 (defcustom gnus-html-cache-directory (nnheader-concat gnus-directory "html-cache/")
  34   "Where Gnus will cache images it downloads from the web."
  35   :group 'gnus-art
  36   :type 'directory)
  37
  38 (defcustom gnus-html-cache-size 500000000
  39   "The size of the Gnus image cache."
  40   :group 'gnus-art
  41   :type 'integer)
  42
  43 (defcustom gnus-html-frame-width 70
  44   "What width to use when rendering HTML."
  45   :group 'gnus-art
  46   :type 'integer)
  47
  48 (defcustom gnus-blocked-images "."
  49   "Images that have URLs matching this regexp will be blocked."
  50   :group 'gnus-art
  51   :type 'regexp)
  52
  53 ;;;###autoload
  54 (defun gnus-article-html (handle)
  55   (let ((article-buffer (current-buffer)))
  56     (save-restriction
  57       (narrow-to-region (point) (point))
  58       (save-excursion
  59         (mm-with-part handle
  60           (let* ((coding-system-for-read 'utf-8)
  61                  (coding-system-for-write 'utf-8)
  62                  (default-process-coding-system
  63                    (cons coding-system-for-read coding-system-for-write)))
  64             (call-process-region (point-min) (point-max)
  65                                  "w3m"
  66                                  nil article-buffer nil
  67                                  "-halfdump"
  68                                  "-no-cookie"
  69                                  "-I" "UTF-8"
  70                                  "-O" "UTF-8"
  71                                  "-o" "ext_halfdump=1"
  72                                  "-o" "pre_conv=1"
  73                                  "-t" (format "%s" tab-width)
  74                                  "-cols" (format "%s" gnus-html-frame-width)
  75                                  "-o" "display_image=off"
  76                                  "-T" "text/html"))))
  77       (gnus-html-wash-tags))))
  78
  79 (defun gnus-html-wash-tags ()
  80   (let (tag parameters string start end images url)
  81     (mm-url-decode-entities)
  82     (goto-char (point-min))
  83     (while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t)
  84       (setq tag (match-string 1)
  85             parameters (match-string 2)
  86             start (match-beginning 0))
  87       (when (plusp (length parameters))
  88         (set-text-properties 0 (1- (length parameters)) nil parameters))
  89       (delete-region start (point))
  90       (when (search-forward (concat "</" tag ">") nil t)
  91         (delete-region (match-beginning 0) (match-end 0)))
  92       (setq end (point))
  93       (cond
  94        ;; Fetch and insert a picture.
  95        ((equal tag "img_alt")
  96         (when (string-match "src=\"\\([^\"]+\\)" parameters)
  97           (setq url (match-string 1 parameters))
  98           (if (string-match "^cid:\\(.*\\)" url)
  99               ;; URLs with cid: have their content stashed in other
 100               ;; parts of the MIME structure, so just insert them
 101               ;; immediately.
 102               (let ((handle (mm-get-content-id
 103                              (setq url (match-string 1 url))))
 104                     image)
 105                 (when handle
 106                   (mm-with-part handle
 107                     (setq image (gnus-create-image (buffer-string)
 108                                                    nil t))))
 109                 (when image
 110                   (delete-region start end)
 111                   (gnus-put-image image)))
 112             ;; Normal, external URL.
 113             (when (or (null gnus-blocked-images)
 114                       (not (string-match gnus-blocked-images url)))
 115               (let ((file (gnus-html-image-id url)))
 116                 (if (file-exists-p file)
 117                     ;; It's already cached, so just insert it.
 118                     (when (gnus-html-put-image file (point))
 119                       ;; Delete the ALT text.
 120                       (delete-region start end))
 121                   ;; We don't have it, so schedule it for fetching
 122                   ;; asynchronously.
 123                   (push (list url
 124                               (set-marker (make-marker) start)
 125                               (point-marker))
 126                         images)))))))
 127        ;; Add a link.
 128        ((equal tag "a")
 129         (when (string-match "href=\"\\([^\"]+\\)" parameters)
 130           (setq url (match-string 1 parameters))
 131           (gnus-article-add-button start end
 132                                    'browse-url url
 133                                    url)
 134           (let ((overlay (gnus-make-overlay start end)))
 135             (gnus-overlay-put overlay 'evaporate t)
 136             (gnus-overlay-put overlay 'gnus-button-url url)
 137             (when gnus-article-mouse-face
 138               (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face)))))
 139        ;; Whatever.  Just ignore the tag.
 140        (t
 141         ))
 142       (goto-char start))
 143     (goto-char (point-min))
 144     ;; The output from -halfdump isn't totally regular, so strip
 145     ;; off any </pre_int>s that were left over.
 146     (while (re-search-forward "</pre_int>" nil t)
 147       (replace-match "" t t))
 148     (when images
 149       (gnus-html-schedule-image-fetching (current-buffer) (nreverse images)))))
 150
 151 (defun gnus-html-schedule-image-fetching (buffer images)
 152   (let* ((url (caar images))
 153          (process (start-process
 154                    "images" nil "curl"
 155                    "-s" "--create-dirs"
 156                    "--location"
 157                    "--max-time" "60"
 158                    "-o" (gnus-html-image-id url)
 159                    url)))
 160     (process-kill-without-query process)
 161     (set-process-sentinel process 'gnus-html-curl-sentinel)
 162     (gnus-set-process-plist process (list 'images images
 163                                           'buffer buffer))))
 164
 165 (defun gnus-html-image-id (url)
 166   (expand-file-name (sha1 url) gnus-html-cache-directory))
 167
 168 (defun gnus-html-curl-sentinel (process event)
 169   (when (string-match "finished" event)
 170     (let* ((images (getf (gnus-process-plist process) 'images))
 171            (buffer (getf (gnus-process-plist process) 'buffer))
 172            (spec (pop images))
 173            (file (gnus-html-image-id (car spec))))
 174       (when (and (buffer-live-p buffer)
 175                  ;; If the position of the marker is 1, then that
 176                  ;; means that the text is was in has been deleted;
 177                  ;; i.e., that the user has selected a different
 178                  ;; article before the image arrived.
 179                  (not (= (marker-position (cadr spec)) 1)))
 180         (save-excursion
 181           (set-buffer buffer)
 182           (let ((buffer-read-only nil))
 183             (when (gnus-html-put-image file (cadr spec))
 184               (delete-region (1+ (cadr spec)) (caddr spec))))))
 185       (when images
 186         (gnus-html-schedule-image-fetching buffer images)))))
 187
 188 (defun gnus-html-put-image (file point)
 189   (when (display-graphic-p)
 190     (let ((image (ignore-errors
 191                    (gnus-create-image file))))
 192       (save-excursion
 193         (goto-char point)
 194         (if (and image
 195                  ;; Kludge to avoid displaying 30x30 gif images, which
 196                  ;; seems to be a signal of a broken image.
 197                  (not (and (listp image)
 198                            (eq (getf (cdr image) :type) 'gif)
 199                            (= (car (image-size image t)) 30)
 200                            (= (cdr (image-size image t)) 30))))
 201             (progn
 202               (gnus-put-image image)
 203               t)
 204           (when (fboundp 'find-image)
 205             (gnus-put-image (find-image
 206                              '((:type xpm :file "lock-broken.xpm")))))
 207           nil)))))
 208
 209 (defun gnus-html-prune-cache ()
 210   (let ((total-size 0)
 211         files)
 212     (dolist (file (directory-files gnus-html-cache-directory t nil t))
 213       (let ((attributes (file-attributes file)))
 214         (unless (nth 0 attributes)
 215           (incf total-size (nth 7 attributes))
 216           (push (list (time-to-seconds (nth 5 attributes))
 217                       (nth 7 attributes) file)
 218                 files))))
 219     (when (> total-size gnus-html-cache-size)
 220       (setq files (sort files (lambda (f1 f2)
 221                                 (< (car f1) (car f2)))))
 222       (dolist (file files)
 223         (when (> total-size gnus-html-cache-size)
 224           (decf total-size (cadr file))
 225           (delete-file (nth 2 file)))))))
 226
 227 ;;;###autoload
 228 (defun gnus-html-prefetch-images (summary)
 229   (let (blocked-images urls)
 230     (when (buffer-live-p summary)
 231       (save-excursion
 232         (set-buffer summary)
 233         (setq blocked-images gnus-blocked-images))
 234       (save-match-data
 235         (while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t)
 236           (let ((url (match-string 1)))
 237             (when (or (null blocked-images)
 238                       (not (string-match blocked-images url)))
 239               (unless (file-exists-p (gnus-html-image-id url))
 240                 (push url urls)
 241                 (push (gnus-html-image-id url) urls)
 242                 (push "-o" urls)))))
 243         (let ((process
 244                (apply 'start-process
 245                       "images" nil "curl"
 246                       "-s" "--create-dirs"
 247                       "--location"
 248                       "--max-time" "60"
 249                       urls)))
 250           (process-kill-without-query process))))))
 251
 252 (provide 'gnus-html)
 253
 254 ;;; gnus-html.el ends here