procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

gnus-html.el: Make gnus-html use url-cache system.

Browse source 
gnus-html.el (gnus-html-image-map): Add v to browse-url on undisplayed image.
This commit is contained in:
Julien Danjou 2010-09-21 11:48:40 +00:00 • committed by Katsumi Yamaoka
parent d19e096ef5
commit 2c8b2fc8d5
2 changed files with 190 additions and 173 deletions
Download patch file Download diff file Expand all files Collapse all files

24
lisp/gnus/ChangeLog
View file

@ -1,3 +1,27 @@
2010-09-21 Julien Danjou <julien@danjou.info>
* gnus-html.el (gnus-html-image-cache-ttl): Add new variable.
(gnus-html-cache-expired): Add new function.
(gnus-html-wash-images): Use `gnus-html-cache-expired' to check
wethever we should display image for fetch it.
Compute alt-text earlier to pass it to the fetching function too.
(gnus-html-schedule-image-fetching): Change function argument to only
get one image at a time, not a list.
(gnus-html-image-fetched): Use `url-store-in-cache' to store image in
cache.
(gnus-html-get-image-data): New function to retrieve image data from
cache.
(gnus-html-put-image): Change buffer argument to use image data rather
than file, and place image above region rather than inserting a new
one. Do not take alt-text as argument, since it's useless now: we place
the image above alt-text.
(gnus-html-prune-cache): Remove.
(gnus-html-show-images): Start to fetch image when we find one, do not
push into a temporary list.
(gnus-html-prefetch-images): Only fetch image if they have expired.
(gnus-html-browse-image): Fix, use 'gnus-image-url.
(gnus-html-image-map): Add "v" to browse-url on undisplayed image.
2010-09-20 Katsumi Yamaoka <yamaoka@jpl.org> 2010-09-20 Katsumi Yamaoka <yamaoka@jpl.org>
* rfc2047.el (rfc2047-encode-parameter): Doc fix. * rfc2047.el (rfc2047-encode-parameter): Doc fix.

339
lisp/gnus/gnus-html.el
View file

@ -34,15 +34,10 @@
(require 'gnus-art) (require 'gnus-art)
(require 'mm-url) (require 'mm-url)
(require 'url) (require 'url)
(require 'url-cache)
(defcustom gnus-html-cache-directory (nnheader-concat gnus-directory "html-cache/") (defcustom gnus-html-image-cache-ttl (days-to-time 7)
"Where Gnus will cache images it downloads from the web." "Time in seconds used to cache the image on disk."
:version "24.1"
:group 'gnus-art
:type 'directory)
(defcustom gnus-html-cache-size 500000000
"The size of the Gnus image cache."
:version "24.1" :version "24.1"
:group 'gnus-art :group 'gnus-art
:type 'integer) :type 'integer)
@ -73,6 +68,7 @@ fit these criteria."
(let ((map (make-sparse-keymap))) (let ((map (make-sparse-keymap)))
(define-key map "u" 'gnus-article-copy-string) (define-key map "u" 'gnus-article-copy-string)
(define-key map "i" 'gnus-html-insert-image) (define-key map "i" 'gnus-html-insert-image)
(define-key map "v" 'gnus-html-browse-url)
map)) map))
(defvar gnus-html-displayed-image-map (defvar gnus-html-displayed-image-map
@ -84,6 +80,19 @@ fit these criteria."
(define-key map [tab] 'widget-forward) (define-key map [tab] 'widget-forward)
map)) map))
(defun gnus-html-cache-expired (url ttl)
"Check if URL is cached for more than TTL."
(cond (url-standalone-mode
(not (file-exists-p (url-cache-create-filename url))))
(t (let ((cache-time (url-is-cached url)))
(if cache-time
(time-less-p
(time-add
cache-time
ttl)
(current-time))
t)))))
;;;###autoload ;;;###autoload
(defun gnus-article-html (&optional handle) (defun gnus-article-html (&optional handle)
(let ((article-buffer (current-buffer))) (let ((article-buffer (current-buffer)))
@ -133,6 +142,7 @@ fit these criteria."
(replace-match "" t t))) (replace-match "" t t)))
(defun gnus-html-wash-images () (defun gnus-html-wash-images ()
"Run through current buffer and replace img tags by images."
(let (tag parameters string start end images url) (let (tag parameters string start end images url)
(goto-char (point-min)) (goto-char (point-min))
;; Search for all the images first. ;; Search for all the images first.
@ -158,62 +168,68 @@ fit these criteria."
(setq image (gnus-create-image (buffer-string) (setq image (gnus-create-image (buffer-string)
nil t)))) nil t))))
(when image (when image
(let ((string (buffer-substring start end))) (let ((string (buffer-substring start end)))
(delete-region start end) (delete-region start end)
(gnus-put-image image (gnus-string-or string "*") 'cid) (gnus-put-image image (gnus-string-or string "*") 'cid)
(gnus-add-image 'cid image)))) (gnus-add-image 'cid image))))
;; Normal, external URL. ;; Normal, external URL.
(if (gnus-html-image-url-blocked-p (let ((alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)"
url parameters)
(if (buffer-live-p gnus-summary-buffer) (match-string 2 parameters))))
(with-current-buffer gnus-summary-buffer (if (gnus-html-image-url-blocked-p
gnus-blocked-images) url
gnus-blocked-images)) (if (buffer-live-p gnus-summary-buffer)
(progn (with-current-buffer gnus-summary-buffer
(widget-convert-button gnus-blocked-images)
'link start end gnus-blocked-images))
:action 'gnus-html-insert-image (progn
:help-echo url (widget-convert-button
:keymap gnus-html-image-map 'link start end
:button-keymap gnus-html-image-map) :action 'gnus-html-insert-image
(let ((overlay (gnus-make-overlay start end)) :help-echo url
(spec (list url :keymap gnus-html-image-map
(set-marker (make-marker) start) :button-keymap gnus-html-image-map)
(set-marker (make-marker) end)))) (let ((overlay (gnus-make-overlay start end))
(gnus-overlay-put overlay 'local-map gnus-html-image-map) (spec (list url
(gnus-overlay-put overlay 'gnus-image spec) (set-marker (make-marker) start)
(gnus-put-text-property (set-marker (make-marker) end)
start end alt-text)))
'gnus-image spec))) (gnus-overlay-put overlay 'local-map gnus-html-image-map)
(let ((file (gnus-html-image-id url)) (gnus-overlay-put overlay 'gnus-image spec)
width height alt-text) (gnus-put-text-property start end 'gnus-image-url url)
(when (string-match "height=\"?\\([0-9]+\\)" parameters) (gnus-put-text-property
(setq height (string-to-number (match-string 1 parameters)))) start end
(when (string-match "width=\"?\\([0-9]+\\)" parameters) 'gnus-image spec)))
(setq width (string-to-number (match-string 1 parameters)))) ;; Non-blocked url
(when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)" (let ((width
parameters) (when (string-match "width=\"?\\([0-9]+\\)" parameters)
(setq alt-text (match-string 2 parameters))) (string-to-number (match-string 1 parameters))))
;; Don't fetch images that are really small. They're (height
;; probably tracking pictures. (when (string-match "height=\"?\\([0-9]+\\)" parameters)
(when (and (or (null height) (string-to-number (match-string 1 parameters)))))
(> height 4)) ;; Don't fetch images that are really small. They're
(or (null width) ;; probably tracking pictures.
(> width 4))) (when (and (or (null height)
(if (file-exists-p file) (> height 4))
;; It's already cached, so just insert it. (or (null width)
(let ((string (buffer-substring start end))) (> width 4)))
;; Delete the IMG text. (gnus-html-display-image url start end alt-text))))))))))
(delete-region start end)
(gnus-html-put-image file (point) string url alt-text)) (defun gnus-html-display-image (url start end alt-text)
;; We don't have it, so schedule it for fetching "Display image at URL on text from START to END.
;; asynchronously. Use ALT-TEXT for the image string."
(push (list url (if (gnus-html-cache-expired url gnus-html-image-cache-ttl)
(set-marker (make-marker) start) ;; We don't have it, so schedule it for fetching
(point-marker)) ;; asynchronously.
images)))))))) (gnus-html-schedule-image-fetching
(when images (current-buffer)
(gnus-html-schedule-image-fetching (current-buffer) (nreverse images))))) (list url
(set-marker (make-marker) start)
(set-marker (make-marker) end)
alt-text))
;; It's already cached, so just insert it.
(gnus-html-put-image (gnus-html-get-image-data url)
start end url alt-text)))
(defun gnus-html-wash-tags () (defun gnus-html-wash-tags ()
(let (tag parameters string start end images url) (let (tag parameters string start end images url)
@ -300,8 +316,7 @@ fit these criteria."
(defun gnus-html-insert-image () (defun gnus-html-insert-image ()
"Fetch and insert the image under point." "Fetch and insert the image under point."
(interactive) (interactive)
(gnus-html-schedule-image-fetching (apply 'gnus-html-display-image (get-text-property (point) 'gnus-image)))
(current-buffer) (list (get-text-property (point) 'gnus-image))))
(defun gnus-html-show-alt-text () (defun gnus-html-show-alt-text ()
"Show the ALT text of the image under point." "Show the ALT text of the image under point."
@ -311,7 +326,7 @@ fit these criteria."
(defun gnus-html-browse-image () (defun gnus-html-browse-image ()
"Browse the image under point." "Browse the image under point."
(interactive) (interactive)
(browse-url (get-text-property (point) 'gnus-image))) (browse-url (get-text-property (point) 'gnus-image-url)))
(defun gnus-html-browse-url () (defun gnus-html-browse-url ()
"Browse the image under point." "Browse the image under point."
@ -321,87 +336,89 @@ fit these criteria."
(message "No URL at point") (message "No URL at point")
(browse-url url)))) (browse-url url))))
(defun gnus-html-schedule-image-fetching (buffer images) (defun gnus-html-schedule-image-fetching (buffer image)
(gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, images %s" "Retrieve IMAGE, and place it into BUFFER on arrival."
buffer images) (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, image %s"
(dolist (image images) buffer image)
(ignore-errors (ignore-errors
(url-retrieve (car image) (url-retrieve (car image)
'gnus-html-image-fetched 'gnus-html-image-fetched
(list buffer image))))) (list buffer image))))
(defun gnus-html-image-id (url)
(expand-file-name (sha1 url) gnus-html-cache-directory))
(defun gnus-html-image-fetched (status buffer image) (defun gnus-html-image-fetched (status buffer image)
(let ((file (gnus-html-image-id (car image)))) (url-store-in-cache (current-buffer))
;; Search the start of the image data (when (and (search-forward "\n\n" nil t)
(when (search-forward "\n\n" nil t) (buffer-live-p buffer)
;; Write region (image data) silently ;; If the `image' has no marker, do not replace anything
(write-region (point) (point-max) file nil 1) (cadr image)
(kill-buffer (current-buffer)) ;; If the position of the marker is 1, then that
(when (and (buffer-live-p buffer) ;; means that the text it was in has been deleted;
;; If the `image' has no marker, do not replace anything ;; i.e., that the user has selected a different
(cadr image) ;; article before the image arrived.
;; If the position of the marker is 1, then that (not (= (marker-position (cadr image))
;; means that the text it was in has been deleted; (with-current-buffer buffer
;; i.e., that the user has selected a different (point-min)))))
;; article before the image arrived. (let ((data (buffer-substring (point) (point-max))))
(not (= (marker-position (cadr image)) (point-min)))) (with-current-buffer buffer
(with-current-buffer buffer (let ((inhibit-read-only t))
(let ((inhibit-read-only t) (gnus-html-put-image data (cadr image) (caddr image) (car image) (cadddr image))))))
(string (buffer-substring (cadr image) (caddr image)))) (kill-buffer (current-buffer)))
(delete-region (cadr image) (caddr image))
(gnus-html-put-image file (cadr image) (car image) string)))))))
(defun gnus-html-put-image (file point string &optional url alt-text) (defun gnus-html-get-image-data (url)
"Get image data for URL.
Return a string with image data."
(with-temp-buffer
(mm-disable-multibyte)
(url-cache-extract (url-cache-create-filename url))
(when (search-forward "\n\n" nil t)
(buffer-substring (point) (point-max)))))
(defun gnus-html-put-image (data start end &optional url alt-text)
(when (gnus-graphic-display-p) (when (gnus-graphic-display-p)
(let* ((image (ignore-errors (let* ((image (ignore-errors
(gnus-create-image file))) (gnus-create-image data nil t)))
(size (and image (size (and image
(if (featurep 'xemacs) (if (featurep 'xemacs)
(cons (glyph-width image) (glyph-height image)) (cons (glyph-width image) (glyph-height image))
(image-size image t))))) (image-size image t)))))
(save-excursion (save-excursion
(goto-char point) (goto-char start)
(if (and image (let ((alt-text (or alt-text (buffer-substring-no-properties start end))))
;; Kludge to avoid displaying 30x30 gif images, which (if (and image
;; seems to be a signal of a broken image. ;; Kludge to avoid displaying 30x30 gif images, which
(not (and (if (featurep 'xemacs) ;; seems to be a signal of a broken image.
(glyphp image) (not (and (if (featurep 'xemacs)
(listp image)) (glyphp image)
(eq (if (featurep 'xemacs) (listp image))
(let ((data (cdadar (specifier-spec-list (eq (if (featurep 'xemacs)
(glyph-image image))))) (let ((d (cdadar (specifier-spec-list
(and (vectorp data) (glyph-image image)))))
(aref data 0))) (and (vectorp d)
(plist-get (cdr image) :type)) (aref d 0)))
'gif) (plist-get (cdr image) :type))
(= (car size) 30) 'gif)
(= (cdr size) 30)))) (= (car size) 30)
(let ((start (point))) (= (cdr size) 30))))
(setq image (gnus-html-rescale-image image file size)) ;; Good image, add it!
(gnus-put-image image (let ((image (gnus-html-rescale-image image data size)))
(gnus-string-or string "*") (delete-region start end)
'external) (gnus-put-image image alt-text 'external)
(let ((overlay (gnus-make-overlay start (point)))) (gnus-overlay-put (gnus-make-overlay start (point)) 'local-map
(gnus-overlay-put overlay 'local-map gnus-html-displayed-image-map)
gnus-html-displayed-image-map) (gnus-put-text-property start (point) 'gnus-alt-text alt-text)
(gnus-put-text-property start (point) 'gnus-alt-text alt-text) (when url
(when url (gnus-put-text-property start (point) 'gnus-image-url url))
(gnus-put-text-property start (point) 'gnus-image url))) (gnus-add-image 'external image)
(gnus-add-image 'external image) t)
t) ;; Bad image, try to show something else
(insert string) (delete-region start end)
(when (fboundp 'find-image) (when (fboundp 'find-image)
(setq image (find-image '((:type xpm :file "lock-broken.xpm")))) (setq image (find-image '((:type xpm :file "lock-broken.xpm"))))
(gnus-put-image image (gnus-put-image image alt-text 'internal)
(gnus-string-or string "*") (gnus-add-image 'internal image))
'internal) nil))))))
(gnus-add-image 'internal image))
nil)))))
(defun gnus-html-rescale-image (image file size) (defun gnus-html-rescale-image (image data size)
(if (or (not (fboundp 'imagemagick-types)) (if (or (not (fboundp 'imagemagick-types))
(not (get-buffer-window (current-buffer)))) (not (get-buffer-window (current-buffer))))
image image
@ -414,35 +431,17 @@ fit these criteria."
(- (nth 3 edges) (nth 1 edges))))) (- (nth 3 edges) (nth 1 edges)))))
scaled-image) scaled-image)
(when (> height window-height) (when (> height window-height)
(setq image (or (create-image file 'imagemagick nil (setq image (or (create-image data 'imagemagick t
:height window-height) :height window-height)
image)) image))
(setq size (image-size image t))) (setq size (image-size image t)))
(when (> (car size) window-width) (when (> (car size) window-width)
(setq image (or (setq image (or
(create-image file 'imagemagick nil (create-image data 'imagemagick t
:width window-width) :width window-width)
image))) image)))
image))) image)))
(defun gnus-html-prune-cache ()
(let ((total-size 0)
files)
(dolist (file (directory-files gnus-html-cache-directory t nil t))
(let ((attributes (file-attributes file)))
(unless (nth 0 attributes)
(incf total-size (nth 7 attributes))
(push (list (time-to-seconds (nth 5 attributes))
(nth 7 attributes) file)
files))))
(when (> total-size gnus-html-cache-size)
(setq files (sort files (lambda (f1 f2)
(< (car f1) (car f2)))))
(dolist (file files)
(when (> total-size gnus-html-cache-size)
(decf total-size (cadr file))
(delete-file (nth 2 file)))))))
(defun gnus-html-image-url-blocked-p (url blocked-images) (defun gnus-html-image-url-blocked-p (url blocked-images)
"Find out if URL is blocked by BLOCKED-IMAGES." "Find out if URL is blocked by BLOCKED-IMAGES."
(let ((ret (and blocked-images (let ((ret (and blocked-images
@ -459,14 +458,10 @@ fit these criteria."
This only works if the article in question is HTML." This only works if the article in question is HTML."
(interactive) (interactive)
(gnus-with-article-buffer (gnus-with-article-buffer
(let ((overlays (overlays-in (point-min) (point-max))) (dolist (overlay (overlays-in (point-min) (point-max)))
overlay images) (let ((o (overlay-get overlay 'gnus-image)))
(while (setq overlay (pop overlays)) (when o
(when (overlay-get overlay 'gnus-image) (apply 'gnus-html-display-image o))))))
(push (overlay-get overlay 'gnus-image) images)))
(if (not images)
(message "No images to show")
(gnus-html-schedule-image-fetching (current-buffer) images)))))
;;;###autoload ;;;###autoload
(defun gnus-html-prefetch-images (summary) (defun gnus-html-prefetch-images (summary)
@ -477,11 +472,9 @@ This only works if the article in question is HTML."
(while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t) (while (re-search-forward "<img.*src=[\"']\\([^\"']+\\)" nil t)
(let ((url (match-string 1))) (let ((url (match-string 1)))
(unless (gnus-html-image-url-blocked-p url blocked-images) (unless (gnus-html-image-url-blocked-p url blocked-images)
(unless (file-exists-p (gnus-html-image-id url)) (when (gnus-html-cache-expired url gnus-html-image-cache-ttl)
(ignore-errors (gnus-html-schedule-image-fetching nil
(url-retrieve (mm-url-decode-entities-string url) (list url))))))))))
'gnus-html-image-fetched
(list nil (list url))))))))))))
(provide 'gnus-html) (provide 'gnus-html)