changeset 110461:9992c4871bd4

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