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

   1 ;;; gnus-html.el --- Render HTML in a buffer.
   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 (eval-when-compile (require 'cl))
  32 (eval-when-compile (require 'mm-decode))
  33
  34 (require 'gnus-art)
  35 (require 'mm-url)
  36 (require 'url)
  37
  38 (defcustom gnus-html-cache-directory (nnheader-concat gnus-directory "html-cache/")
  39   "Where Gnus will cache images it downloads from the web."
  40   :version "24.1"
  41   :group 'gnus-art
  42   :type 'directory)
  43
  44 (defcustom gnus-html-cache-size 500000000
  45   "The size of the Gnus image cache."
  46   :version "24.1"
  47   :group 'gnus-art
  48   :type 'integer)
  49
  50 (defcustom gnus-html-frame-width 70
  51   "What width to use when rendering HTML."
  52   :version "24.1"
  53   :group 'gnus-art
  54   :type 'integer)
  55
  56 (defcustom gnus-blocked-images "."
  57   "Images that have URLs matching this regexp will be blocked."
  58   :version "24.1"
  59   :group 'gnus-art
  60   :type 'regexp)
  61
  62 (defcustom gnus-max-image-proportion 0.7
  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     map))
  77
  78 (defvar gnus-html-displayed-image-map
  79   (let ((map (make-sparse-keymap)))
  80     (define-key map "a" 'gnus-html-show-alt-text)
  81     (define-key map "i" 'gnus-html-browse-image)
  82     (define-key map "\r" 'gnus-html-browse-url)
  83     (define-key map "u" 'gnus-article-copy-string)
  84     (define-key map [tab] 'widget-forward)
  85     map))
  86
  87 ;;;###autoload
  88 (defun gnus-article-html (&optional handle)
  89   (let ((article-buffer (current-buffer)))
  90     (unless handle
  91       (setq handle (mm-dissect-buffer t)))
  92     (save-restriction
  93       (narrow-to-region (point) (point))
  94       (save-excursion
  95         (mm-with-part handle
  96           (let* ((coding-system-for-read 'utf-8)
  97                  (coding-system-for-write 'utf-8)
  98                  (default-process-coding-system
  99                    (cons coding-system-for-read coding-system-for-write))
 100                  (charset (mail-content-type-get (mm-handle-type handle)
 101                                                  'charset)))
 102             (when (and charset
 103                        (setq charset (mm-charset-to-coding-system charset))
 104                        (not (eq charset 'ascii)))
 105               (insert (prog1
 106                           (mm-decode-coding-string (buffer-string) charset)
 107                         (erase-buffer)
 108                         (mm-enable-multibyte))))
 109             (call-process-region (point-min) (point-max)
 110                                  "w3m"
 111                                  nil article-buffer nil
 112                                  "-halfdump"
 113                                  "-no-cookie"
 114                                  "-I" "UTF-8"
 115                                  "-O" "UTF-8"
 116                                  "-o" "ext_halfdump=1"
 117                                  "-o" "display_ins_del=2"
 118                                  "-o" "pre_conv=1"
 119                                  "-t" (format "%s" tab-width)
 120                                  "-cols" (format "%s" gnus-html-frame-width)
 121                                  "-o" "display_image=on"
 122                                  "-T" "text/html"))))
 123       (gnus-html-wash-tags))))
 124
 125 (defvar gnus-article-mouse-face)
 126
 127 (defun gnus-html-pre-wash ()
 128   (goto-char (point-min))
 129   (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t)
 130     (replace-match "" t t))
 131   (goto-char (point-min))
 132   (while (re-search-forward "<a name[^\n>]+>" nil t)
 133     (replace-match "" t t)))
 134
 135 (defun gnus-html-wash-images ()
 136   (let (tag parameters string start end images url)
 137     (goto-char (point-min))
 138     ;; Search for all the images first.
 139     (while (re-search-forward "<img_alt \\([^>]*\\)>" nil t)
 140       (setq parameters (match-string 1)
 141             start (match-beginning 0))
 142       (delete-region start (point))
 143       (when (search-forward "</img_alt>" (line-end-position) t)
 144         (delete-region (match-beginning 0) (match-end 0)))
 145       (setq end (point))
 146       (when (string-match "src=\"\\([^\"]+\\)" parameters)
 147         (setq url (match-string 1 parameters))
 148         (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url)
 149         (if (string-match "^cid:\\(.*\\)" url)
 150             ;; URLs with cid: have their content stashed in other
 151             ;; parts of the MIME structure, so just insert them
 152             ;; immediately.
 153             (let ((handle (mm-get-content-id
 154                            (setq url (match-string 1 url))))
 155                   image)
 156               (when handle
 157                 (mm-with-part handle
 158                   (setq image (gnus-create-image (buffer-string)
 159                                                  nil t))))
 160               (when image
 161                 (let ((string (buffer-substring start end)))
 162                   (delete-region start end)
 163                   (gnus-put-image image (gnus-string-or string "*") 'cid)
 164                   (gnus-add-image 'cid image))))
 165           ;; Normal, external URL.
 166           (if (gnus-html-image-url-blocked-p
 167                url
 168                (if (buffer-live-p gnus-summary-buffer)
 169                    (with-current-buffer gnus-summary-buffer
 170                      gnus-blocked-images)
 171                  gnus-blocked-images))
 172               (progn
 173                 (widget-convert-button
 174                  'link start end
 175                  :action 'gnus-html-insert-image
 176                  :help-echo url
 177                  :keymap gnus-html-image-map
 178                  :button-keymap gnus-html-image-map)
 179                 (let ((overlay (gnus-make-overlay start end))
 180                       (spec (list url
 181                                   (set-marker (make-marker) start)
 182                                   (set-marker (make-marker) end))))
 183                   (gnus-overlay-put overlay 'local-map gnus-html-image-map)
 184                   (gnus-overlay-put overlay 'gnus-image spec)
 185                   (gnus-put-text-property
 186                    start end
 187                    'gnus-image spec)))
 188             (let ((file (gnus-html-image-id url))
 189                   width height alt-text)
 190               (when (string-match "height=\"?\\([0-9]+\\)" parameters)
 191                 (setq height (string-to-number (match-string 1 parameters))))
 192               (when (string-match "width=\"?\\([0-9]+\\)" parameters)
 193                 (setq width (string-to-number (match-string 1 parameters))))
 194               (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)"
 195                                   parameters)
 196                 (setq alt-text (match-string 2 parameters)))
 197               ;; Don't fetch images that are really small.  They're
 198               ;; probably tracking pictures.
 199               (when (and (or (null height)
 200                              (> height 4))
 201                          (or (null width)
 202                              (> width 4)))
 203                 (if (file-exists-p file)
 204                     ;; It's already cached, so just insert it.
 205                     (let ((string (buffer-substring start end)))
 206                       ;; Delete the IMG text.
 207                       (delete-region start end)
 208                       (gnus-html-put-image file (point) string url alt-text))
 209                   ;; We don't have it, so schedule it for fetching
 210                   ;; asynchronously.
 211                   (push (list url
 212                               (set-marker (make-marker) start)
 213                               (point-marker))
 214                         images))))))))
 215     (when images
 216       (gnus-html-schedule-image-fetching (current-buffer) (nreverse images)))))
 217
 218 (defun gnus-html-wash-tags ()
 219   (let (tag parameters string start end images url)
 220     (gnus-html-pre-wash)
 221     (gnus-html-wash-images)
 222
 223     (goto-char (point-min))
 224     ;; Then do the other tags.
 225     (while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t)
 226       (setq tag (match-string 1)
 227             parameters (match-string 2)
 228             start (match-beginning 0))
 229       (when (plusp (length parameters))
 230         (set-text-properties 0 (1- (length parameters)) nil parameters))
 231       (delete-region start (point))
 232       (when (search-forward (concat "</" tag ">") nil t)
 233         (delete-region (match-beginning 0) (match-end 0)))
 234       (setq end (point))
 235       (cond
 236        ;; Fetch and insert a picture.
 237        ((equal tag "img_alt"))
 238        ;; Add a link.
 239        ((or (equal tag "a")
 240             (equal tag "A"))
 241         (when (string-match "href=\"\\([^\"]+\\)" parameters)
 242           (setq url (match-string 1 parameters))
 243           (gnus-message 8 "gnus-html-wash-tags: fetching link URL %s" url)
 244           (gnus-article-add-button start end
 245                                    'browse-url url
 246                                    url)
 247           (let ((overlay (gnus-make-overlay start end)))
 248             (gnus-overlay-put overlay 'evaporate t)
 249             (gnus-overlay-put overlay 'gnus-button-url url)
 250             (gnus-put-text-property start end 'gnus-string url)
 251             (when gnus-article-mouse-face
 252               (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face)))))
 253        ;; The upper-case IMG_ALT is apparently just an artifact that
 254        ;; should be deleted.
 255        ((equal tag "IMG_ALT")
 256         (delete-region start end))
 257        ;; w3m does not normalize the case
 258        ((or (equal tag "b")
 259             (equal tag "B"))
 260         (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-bold))
 261        ((or (equal tag "u")
 262             (equal tag "U"))
 263         (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline))
 264        ((or (equal tag "i")
 265             (equal tag "I"))
 266         (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-italic))
 267        ((or (equal tag "s")
 268             (equal tag "S"))
 269         (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-strikethru))
 270        ((or (equal tag "ins")
 271             (equal tag "INS"))
 272         (gnus-overlay-put (gnus-make-overlay start end) 'face 'gnus-emphasis-underline))
 273        ;; Handle different UL types
 274        ((equal tag "_SYMBOL")
 275         (when (string-match "TYPE=\\(.+\\)" parameters)
 276           (let ((type (string-to-number (match-string 1 parameters))))
 277             (delete-region start end)
 278             (cond ((= type 33) (insert " "))
 279                   ((= type 34) (insert " "))
 280                   ((= type 35) (insert " "))
 281                   ((= type 36) (insert " "))
 282                   ((= type 37) (insert " "))
 283                   ((= type 38) (insert " "))
 284                   ((= type 39) (insert " "))
 285                   ((= type 40) (insert " "))
 286                   ((= type 42) (insert " "))
 287                   ((= type 43) (insert " "))
 288                   (t (insert " "))))))
 289        ;; Whatever.  Just ignore the tag.
 290        (t
 291         ))
 292       (goto-char start))
 293     (goto-char (point-min))
 294     ;; The output from -halfdump isn't totally regular, so strip
 295     ;; off any </pre_int>s that were left over.
 296     (while (re-search-forward "</pre_int>\\|</internal>" nil t)
 297       (replace-match "" t t))
 298     (mm-url-decode-entities)))
 299
 300 (defun gnus-html-insert-image ()
 301   "Fetch and insert the image under point."
 302   (interactive)
 303   (gnus-html-schedule-image-fetching
 304    (current-buffer) (list (get-text-property (point) 'gnus-image))))
 305
 306 (defun gnus-html-show-alt-text ()
 307   "Show the ALT text of the image under point."
 308   (interactive)
 309   (message "%s" (get-text-property (point) 'gnus-alt-text)))
 310
 311 (defun gnus-html-browse-image ()
 312   "Browse the image under point."
 313   (interactive)
 314   (browse-url (get-text-property (point) 'gnus-image)))
 315
 316 (defun gnus-html-browse-url ()
 317   "Browse the image under point."
 318   (interactive)
 319   (let ((url (get-text-property (point) 'gnus-string)))
 320     (if (not url)
 321         (message "No URL at point")
 322       (browse-url url))))
 323
 324 (defun gnus-html-schedule-image-fetching (buffer images)
 325   (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, images %s"
 326                 buffer images)
 327   (dolist (image images)
 328     (ignore-errors
 329       (url-retrieve (car image)
 330                     'gnus-html-image-fetched
 331                     (list buffer image)))))
 332
 333 (defun gnus-html-image-id (url)
 334   (expand-file-name (sha1 url) gnus-html-cache-directory))
 335
 336 (defun gnus-html-image-fetched (status buffer image)
 337   (let ((file (gnus-html-image-id (car image))))
 338     ;; Search the start of the image data
 339     (search-forward "\n\n")
 340     ;; Write region (image data) silently
 341     (write-region (point) (point-max) file nil 1)
 342     (kill-buffer)
 343     (when (and (buffer-live-p buffer)
 344                ;; If the `image' has no marker, do not replace anything
 345                (cadr image)
 346                ;; If the position of the marker is 1, then that
 347                ;; means that the text it was in has been deleted;
 348                ;; i.e., that the user has selected a different
 349                ;; article before the image arrived.
 350                (not (= (marker-position (cadr image)) (point-min))))
 351       (with-current-buffer buffer
 352         (let ((inhibit-read-only t)
 353               (string (buffer-substring (cadr image) (caddr image))))
 354           (delete-region (cadr image) (caddr image))
 355           (gnus-html-put-image file (cadr image) (car image) string))))))
 356
 357 (defun gnus-html-put-image (file point string &optional url alt-text)
 358   (when (gnus-graphic-display-p)
 359     (let* ((image (ignore-errors
 360                    (gnus-create-image file)))
 361           (size (and image
 362                      (if (featurep 'xemacs)
 363                          (cons (glyph-width image) (glyph-height image))
 364                        (image-size image t)))))
 365       (save-excursion
 366         (goto-char point)
 367         (if (and image
 368                  ;; Kludge to avoid displaying 30x30 gif images, which
 369                  ;; seems to be a signal of a broken image.
 370                  (not (and (if (featurep 'xemacs)
 371                                (glyphp image)
 372                              (listp image))
 373                            (eq (if (featurep 'xemacs)
 374                                    (let ((data (cdadar (specifier-spec-list
 375                                                         (glyph-image image)))))
 376                                      (and (vectorp data)
 377                                           (aref data 0)))
 378                                  (plist-get (cdr image) :type))
 379                                'gif)
 380                            (= (car size) 30)
 381                            (= (cdr size) 30))))
 382             (let ((start (point)))
 383               (setq image (gnus-html-rescale-image image file size))
 384               (gnus-put-image image
 385                               (gnus-string-or string "*")
 386                               'external)
 387               (let ((overlay (gnus-make-overlay start (point))))
 388                 (gnus-overlay-put overlay 'local-map
 389                                   gnus-html-displayed-image-map)
 390                 (gnus-put-text-property start (point) 'gnus-alt-text alt-text)
 391                 (when url
 392                   (gnus-put-text-property start (point) 'gnus-image url)))
 393               (gnus-add-image 'external image)
 394               t)
 395           (insert string)
 396           (when (fboundp 'find-image)
 397             (setq image (find-image '((:type xpm :file "lock-broken.xpm"))))
 398             (gnus-put-image image
 399                             (gnus-string-or string "*")
 400                             'internal)
 401             (gnus-add-image 'internal image))
 402           nil)))))
 403
 404 (defun gnus-html-rescale-image (image file size)
 405   (if (or (not (fboundp 'imagemagick-types))
 406           (not (get-buffer-window (current-buffer))))
 407       image
 408     (let* ((width (car size))
 409            (height (cdr size))
 410            (edges (window-pixel-edges (get-buffer-window (current-buffer))))
 411            (window-width (truncate (* gnus-max-image-proportion
 412                                       (- (nth 2 edges) (nth 0 edges)))))
 413            (window-height (truncate (* gnus-max-image-proportion
 414                                        (- (nth 3 edges) (nth 1 edges)))))
 415            scaled-image)
 416       (when (> height window-height)
 417         (setq image (or (create-image file 'imagemagick nil
 418                                       :height window-height)
 419                         image))
 420         (setq size (image-size image t)))
 421       (when (> (car size) window-width)
 422         (setq image (or
 423                      (create-image file 'imagemagick nil
 424                                    :width window-width)
 425                      image)))
 426       image)))
 427
 428 (defun gnus-html-prune-cache ()
 429   (let ((total-size 0)
 430         files)
 431     (dolist (file (directory-files gnus-html-cache-directory t nil t))
 432       (let ((attributes (file-attributes file)))
 433         (unless (nth 0 attributes)
 434           (incf total-size (nth 7 attributes))
 435           (push (list (time-to-seconds (nth 5 attributes))
 436                       (nth 7 attributes) file)
 437                 files))))
 438     (when (> total-size gnus-html-cache-size)
 439       (setq files (sort files (lambda (f1 f2)
 440                                 (< (car f1) (car f2)))))
 441       (dolist (file files)
 442         (when (> total-size gnus-html-cache-size)
 443           (decf total-size (cadr file))
 444           (delete-file (nth 2 file)))))))
 445
 446 (defun gnus-html-image-url-blocked-p (url blocked-images)
 447   "Find out if URL is blocked by BLOCKED-IMAGES."
 448   (let ((ret (and blocked-images
 449                   (string-match blocked-images url))))
 450     (if ret
 451         (gnus-message 8 "gnus-html-image-url-blocked-p: %s blocked by regex %s"
 452                       url blocked-images)
 453       (gnus-message 9 "gnus-html-image-url-blocked-p: %s passes regex %s"
 454                     url blocked-images))
 455     ret))
 456
 457 (defun gnus-html-show-images ()
 458   "Show any images that are in the HTML-rendered article buffer.
 459 This only works if the article in question is HTML."
 460   (interactive)
 461   (gnus-with-article-buffer
 462     (let ((overlays (overlays-in (point-min) (point-max)))
 463           overlay images)
 464       (while (setq overlay (pop overlays))
 465         (when (overlay-get overlay 'gnus-image)
 466           (push (overlay-get overlay 'gnus-image) images)))
 467       (if (not images)
 468           (message "No images to show")
 469         (gnus-html-schedule-image-fetching (current-buffer) images)))))
 470
 471 ;;;###autoload
 472 (defun gnus-html-prefetch-images (summary)
 473   (when (buffer-live-p summary)
 474     (let ((blocked-images (with-current-buffer summary
 475                             gnus-blocked-images)))
 476       (save-match-data
 477         (while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t)
 478           (let ((url (match-string 1)))
 479             (unless (gnus-html-image-url-blocked-p url blocked-images)
 480               (unless (file-exists-p (gnus-html-image-id url))
 481                 (ignore-errors
 482                   (url-retrieve (mm-url-decode-entities-string url)
 483                                 'gnus-html-image-fetched))))))))))
 484
 485 (provide 'gnus-html)
 486
 487 ;;; gnus-html.el ends here