gnus-html (gnus-html-wash-tags): Search for images first, so that <a><img> works better; (gnus-html-displayed-image-map): Bind RET and TAB on images for better UX.

2 files changed, 103 insertions, 75 deletions

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 29e17b99e64..f518536685d 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -4,6 +4,8 @@
         (gnus-html-browse-image): Ditto.
         (gnus-html-wash-tags): Add the data to allow showing the ALT text and
         to browse the image directly.
+        (gnus-html-wash-tags): Search for images first, so that <a><img> works
+        better.
 
         * gnus-async.el (gnus-async-article-callback): Call
         `gnus-html-prefetch-images' unconditionally.
diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el
index fc672197467..03089414e3f 100644
--- a/lisp/gnus/gnus-html.el
+++ b/lisp/gnus/gnus-html.el
@@ -76,6 +76,9 @@ fit these criteria."
   (let ((map (make-sparse-keymap)))
     (define-key map "a" 'gnus-html-show-alt-text)
     (define-key map "i" 'gnus-html-browse-image)
+    (define-key map "\r" 'gnus-html-browse-url)
+    (define-key map "u" 'gnus-article-copy-string)
+    (define-key map [tab] 'widget-forward)
     map))
 
 ;;;###autoload
@@ -117,15 +120,99 @@ fit these criteria."
 
 (defvar gnus-article-mouse-face)
 
+(defun gnus-html-pre-wash ()
+  (goto-char (point-min))
+  (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t)
+    (replace-match "" t t))
+  (goto-char (point-min))
+  (while (re-search-forward "<a name[^\n>]+>" nil t)
+    (replace-match "" t t)))
+
 (defun gnus-html-wash-tags ()
   (let (tag parameters string start end images url)
+    (gnus-html-pre-wash)
     (goto-char (point-min))
-    (while (re-search-forward " *<pre_int> *</pre_int> *\n" nil t)
-      (replace-match "" t t))
-    (goto-char (point-min))
-    (while (re-search-forward "<a name[^\n>]+>" nil t)
-      (replace-match "" t t))
+
+    ;; Search for all the images first.
+    (while (re-search-forward "<img_alt \\([^>]*\\)>" nil t)
+      (setq parameters (match-string 1)
+            start (match-beginning 0))
+      (delete-region start (point))
+      (when (search-forward "</img_alt>" (line-end-position) t)
+        (delete-region (match-beginning 0) (match-end 0)))
+      (setq end (point))
+      (when (string-match "src=\"\\([^\"]+\\)" parameters)
+        (setq url (match-string 1 parameters))
+        (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url)
+        (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
+                (mm-with-part handle
+                  (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))))
+          ;; 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))))))))
+
     (goto-char (point-min))
+    ;; Then do the other tags.
     (while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t)
       (setq tag (match-string 1)
             parameters (match-string 2)
@@ -138,76 +225,7 @@ fit these criteria."
       (setq end (point))
       (cond
        ;; Fetch and insert a picture.
-       ((equal tag "img_alt")
-        (when (string-match "src=\"\\([^\"]+\\)" parameters)
-          (setq url (match-string 1 parameters))
-          (gnus-message 8 "gnus-html-wash-tags: fetching image URL %s" url)
-          (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
-                  (mm-with-part handle
-                    (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))))
-            ;; 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))))))))
+       ((equal tag "img_alt"))
        ;; Add a link.
        ((or (equal tag "a")
             (equal tag "A"))
@@ -256,6 +274,14 @@ fit these criteria."
   (interactive)
   (browse-url (get-text-property (point) 'gnus-image)))
 
+(defun gnus-html-browse-url ()
+  "Browse the image under point."
+  (interactive)
+  (let ((url (get-text-property (point) 'gnus-string)))
+    (if (not url)
+        (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)