gnus-html.el: Don't display images if gnus-inhibit-images is non-nil.

(gnus-html-wash-images): Don't display images if gnus-inhibit-images is non-nil; register displayer for cid images.
(gnus-html-display-image): Work for cid image.
(gnus-html-insert-image): Allow arguments.
(gnus-html-put-image): Inhibit read-only.
(gnus-html-prefetch-images): Don't prefetch images if gnus-inhibit-images is non-nil.

2 files changed, 92 insertions, 68 deletions

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index a22314646f4..7b5fb12361f 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,13 @@
+2010-11-18  Katsumi Yamaoka  <yamaoka@jpl.org>
+
+        * gnus-html.el (gnus-html-wash-images): Don't display images if
+        gnus-inhibit-images is non-nil; register displayer for cid images.
+        (gnus-html-display-image): Work for cid image.
+        (gnus-html-insert-image): Allow arguments.
+        (gnus-html-put-image): Inhibit read-only.
+        (gnus-html-prefetch-images): Don't prefetch images if
+        gnus-inhibit-images is non-nil.
+
 2010-11-17  Lars Magne Ingebrigtsen  <larsi@gnus.org>
 
         * shr.el (shr-put-image): Break lines when inserting big pictures.
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
index dc2400c0246..4df9a0fbedc 100644
--- a/lisp/gnus/gnus-html.el
+++ b/lisp/gnus/gnus-html.el
@@ -169,7 +169,7 @@ CHARS is a regexp-like character alternative (e.g., \"[)$]\")."
 
 (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 alt-text)
     (goto-char (point-min))
     ;; Search for all the images first.
     (while (re-search-forward "<img_alt \\([^>]*\\)>" nil t)
@@ -180,81 +180,93 @@ CHARS is a regexp-like character alternative (e.g., \"[)$]\")."
         (delete-region (match-beginning 0) (match-end 0)))
       (setq end (point))
       (when (string-match "src=\"\\([^\"]+\\)" parameters)
-        (setq url (gnus-html-encode-url (match-string 1 parameters)))
         (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url)
-        (if (string-match "^cid:\\(.*\\)" url)
+        (setq url (gnus-html-encode-url (match-string 1 parameters))
+              alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)"
+                                           parameters)
+                         (xml-substitute-special (match-string 2 parameters))))
+        (gnus-add-text-properties
+         start end
+         (list 'image-url url
+               'image-displayer `(lambda (url start end)
+                                   (gnus-html-display-image url start end
+                                                            ,alt-text))
+               'gnus-image (list url start end alt-text)))
+        (gnus-overlay-put (gnus-make-overlay start end)
+                          'local-map gnus-html-image-map)
+        (if (string-match "\\`cid:" url)
             ;; URLs with cid: have their content stashed in other
             ;; parts of the MIME structure, so just insert them
             ;; immediately.
-            (let* ((handle (mm-get-content-id
-                            (setq url (match-string 1 url))))
-                   (image (when handle
-                            (gnus-create-image
+            (let* ((handle (mm-get-content-id (substring url (match-end 0))))
+                   (image (when (and handle
+                                     (not gnus-inhibit-images))
+                            (gnus-create-image
                              (mm-with-part handle (buffer-string))
                              nil t))))
-              (when image
-                (let ((string (buffer-substring start end)))
-                  (delete-region start end)
-                  (gnus-put-image (gnus-rescale-image
-                                   image (gnus-html-maximum-image-size))
-                                  (gnus-string-or string "*") 'cid)
-                  (gnus-add-image 'cid image))))
+              (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))
+                (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)))
           ;; Normal, external URL.
-          (let ((alt-text
-                 (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)"
-                                     parameters)
-                   (xml-substitute-special (match-string 2 parameters)))))
-            (gnus-put-text-property start end 'image-url url)
-            (gnus-put-text-property
-             start end 'image-displayer
-             (lambda (url start end)
-               (gnus-html-display-image url start end)))
-            (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 start 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 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))))))))))
+          (if (or gnus-inhibit-images
+                  (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))))
+              (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)
+            ;; 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 &optional 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 alt-text))
-    ;; It's already cached, so just insert it.
-    (gnus-html-put-image (gnus-html-get-image-data url) url (or alt-text "*"))))
+  (or alt-text (setq alt-text "*"))
+  (if (string-match "\\`cid:" url)
+      (let ((handle (mm-get-content-id (substring url (match-end 0)))))
+        (when handle
+          (gnus-html-put-image (mm-with-part handle (buffer-string))
+                               url alt-text)))
+    (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 alt-text))
+      ;; It's already cached, so just insert it.
+      (gnus-html-put-image (gnus-html-get-image-data url) url alt-text))))
 
 (defun gnus-html-wash-tags ()
   (let (tag parameters string start end images url)
@@ -338,7 +350,7 @@ Use ALT-TEXT for the image string."
       (replace-match "" t t))
     (mm-url-decode-entities)))
 
-(defun gnus-html-insert-image ()
+(defun gnus-html-insert-image (&rest args)
   "Fetch and insert the image under point."
   (interactive)
   (apply 'gnus-html-display-image (get-text-property (point) 'gnus-image)))
@@ -437,7 +449,8 @@ Return a string with image data."
           (save-excursion
             (goto-char start)
             (let ((alt-text (or alt-text
-                                (buffer-substring-no-properties start end))))
+                                (buffer-substring-no-properties start end)))
+                  (inhibit-read-only t))
               (if (and image
                        ;; Kludge to avoid displaying 30x30 gif images, which
                        ;; seems to be a signal of a broken image.
@@ -498,7 +511,8 @@ Return a string with image data."
         (while (re-search-forward "<img[^>]+src=[\"']\\(http[^\"']+\\)" nil t)
           (let ((url (gnus-html-encode-url
                       (mm-url-decode-entities-string (match-string 1)))))
-            (unless (gnus-html-image-url-blocked-p url blocked-images)
+            (unless (or gnus-inhibit-images
+                        (gnus-html-image-url-blocked-p url blocked-images))
               (when (gnus-html-cache-expired url gnus-html-image-cache-ttl)
                 (gnus-html-schedule-image-fetching nil
                                                    (list url))))))))))