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.

2 files changed, 191 insertions, 174 deletions

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index b85618ae705..6ca3a0198c6 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -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.
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
index 78bb7ca18b5..34dbb4dd878 100644
--- a/lisp/gnus/gnus-html.el
+++ b/lisp/gnus/gnus-html.el
@@ -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 @@ fit these criteria."
   (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 @@ fit these criteria."
     (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 @@ fit these criteria."
     (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 @@ fit these criteria."
                   (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 @@ fit these criteria."
 (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 @@ fit these criteria."
 (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 @@ fit these criteria."
         (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)))))))
-
-(defun gnus-html-put-image (file point string &optional url alt-text)
+      (buffer-substring (point) (point-max)))))
+
+(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)))))
-
-(defun gnus-html-rescale-image (image file size)
+        (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 data size)
   (if (or (not (fboundp 'imagemagick-types))
           (not (get-buffer-window (current-buffer))))
       image
@@ -414,35 +431,17 @@ fit these criteria."
                                        (- (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 @@ fit these criteria."
 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 @@ This only works if the article in question is HTML."
         (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)