shr.el (shr-put-image-function): New variable.

 (shr-image-fetched, shr-image-displayer, shr-tag-img): Funcall it.
 (shr-put-image): Return scaled image.
gnus-art.el (gnus-shr-put-image): New function.
 (gnus-article-prepare-display): Bind shr-put-image-function to it.
gnus-html.el (gnus-html-wash-images): Register scaled images, not original ones, as deletable.

4 files changed, 45 insertions, 16 deletions

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index aa07038635d..1460896dd89 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,15 @@
+2011-05-10  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+        * shr.el (shr-put-image-function): New variable.
+        (shr-image-fetched, shr-image-displayer, shr-tag-img): Funcall it.
+        (shr-put-image): Return scaled image.
+
+        * gnus-art.el (gnus-shr-put-image): New function.
+        (gnus-article-prepare-display): Bind shr-put-image-function to it.
+
+        * gnus-html.el (gnus-html-wash-images): Register scaled images, not
+        original ones, as deletable.
+
 2011-05-09  Stefan Monnier  <monnier@iro.umontreal.ca>
 
         * nntp.el (nntp-open-connection): Set TCP keepalive option.
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index 690e29cb65a..13531bf434e 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -4656,6 +4656,8 @@ If ALL-HEADERS is non-nil, no headers are hidden."
             (gnus-run-hooks 'gnus-article-prepare-hook)
             t))))))
 
+(defvar shr-put-image-function)
+
 ;;;###autoload
 (defun gnus-article-prepare-display ()
   "Make the current buffer look like a nice article."
@@ -4669,6 +4671,7 @@ If ALL-HEADERS is non-nil, no headers are hidden."
     (setq buffer-read-only nil
           gnus-article-wash-types nil
           gnus-article-image-alist nil)
+    (set (make-local-variable 'shr-put-image-function) 'gnus-shr-put-image)
     (gnus-run-hooks 'gnus-tmp-internal-hook)
     (when gnus-display-mime-function
       (funcall gnus-display-mime-function))))
@@ -6139,6 +6142,15 @@ Provided for backwards compatibility."
              (not gnus-inhibit-hiding))
     (gnus-article-hide-headers)))
 
+(declare-function shr-put-image "shr" (data alt))
+
+(defun gnus-shr-put-image (data alt)
+  "Put image DATA with a string ALT.  Enable image to be deleted."
+  (let ((image (shr-put-image data (propertize (or alt "*")
+                                               'gnus-image-category 'shr))))
+    (when image
+      (gnus-add-image 'shr image))))
+
 ;;; Article savers.
 
 (defun gnus-output-to-file (file-name)
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
index f380d079d7b..b7f0c0922a3 100644
--- a/lisp/gnus/gnus-html.el
+++ b/lisp/gnus/gnus-html.el
@@ -215,16 +215,16 @@ CHARS is a regexp-like character alternative (e.g., \"[)$]\")."
                              (mm-with-part handle (buffer-string))
                              nil t))))
               (if image
-                  (progn
-                    (gnus-put-image
-                     (gnus-rescale-image
-                      image (gnus-html-maximum-image-size))
-                     (gnus-string-or (prog1
-                                         (buffer-substring start end)
-                                       (delete-region start end))
-                                     "*")
-                     'cid)
-                    (gnus-add-image 'cid image))
+                  (gnus-add-image
+                   'cid
+                   (gnus-put-image
+                    (gnus-rescale-image
+                     image (gnus-html-maximum-image-size))
+                    (gnus-string-or (prog1
+                                        (buffer-substring start end)
+                                      (delete-region start end))
+                                    "*")
+                    'cid))
                 (widget-convert-button
                  'link start end
                  :action 'gnus-html-insert-image
diff --git a/lisp/gnus/shr.el b/lisp/gnus/shr.el
index 2e7968e8dee..da27edca6e5 100644
--- a/lisp/gnus/shr.el
+++ b/lisp/gnus/shr.el
@@ -87,6 +87,9 @@ used."
 This is used for cid: URLs, and the function is called with the
 cid: URL as the argument.")
 
+(defvar shr-put-image-function 'shr-put-image
+  "Function called to put image and alt string.")
+
 (defface shr-strike-through '((t (:strike-through t)))
   "Font for <s> elements."
   :group 'shr)
@@ -500,10 +503,11 @@ redirects somewhere else."
                   (inhibit-read-only t))
               (delete-region start end)
               (goto-char start)
-              (shr-put-image data alt)))))))
+              (funcall shr-put-image-function data alt)))))))
   (kill-buffer (current-buffer)))
 
 (defun shr-put-image (data alt)
+  "Put image DATA with a string ALT.  Return image."
   (if (display-graphic-p)
       (let ((image (ignore-errors
                      (shr-rescale-image data))))
@@ -513,7 +517,8 @@ redirects somewhere else."
           (when (and (> (current-column) 0)
                      (> (car (image-size image t)) 400))
             (insert "\n"))
-          (insert-image image (or alt "*"))))
+          (insert-image image (or alt "*")))
+        image)
     (insert alt)))
 
 (defun shr-rescale-image (data)
@@ -576,8 +581,8 @@ START, and END.  Note that START and END should be merkers."
                                      (substring url (match-end 0)))))
                  (when image
                    (goto-char start)
-                   (shr-put-image image
-                                  (buffer-substring-no-properties start end))
+                   (funcall shr-put-image-function
+                            image (buffer-substring-no-properties start end))
                    (delete-region (point) end))))
          (url-retrieve url 'shr-image-fetched
                        (list (current-buffer) start end)
@@ -864,7 +869,7 @@ ones, in case fg and bg are nil."
             (if (or (not shr-content-function)
                     (not (setq image (funcall shr-content-function url))))
                 (insert alt)
-              (shr-put-image image alt))))
+              (funcall shr-put-image-function image alt))))
          ((or shr-inhibit-images
               (and shr-blocked-images
                    (string-match shr-blocked-images url)))
@@ -874,7 +879,7 @@ ones, in case fg and bg are nil."
                 (shr-insert (truncate-string-to-width alt 8))
               (shr-insert alt))))
          ((url-is-cached (shr-encode-url url))
-          (shr-put-image (shr-get-image-data url) alt))
+          (funcall shr-put-image-function (shr-get-image-data url) alt))
          (t
           (insert alt)
           (funcall