Don't bind image commands on non-image links in Gnus

* lisp/gnus/mm-decode.el (mm--images-in-region-p): New utility
function.
(mm-convert-shr-links): Only use the shr image map on links that
contain images.  This avoids binding commands like `r' on links
that don't need it.

diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index 7ab84c0c83d52002262c9a78471d7a7e99b2cb56..d8753e5a1d5f4a594c4f28ce861007af4e68f1f5 100644 (file)
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -25,6 +25,7 @@
 
 (require 'mail-parse)
 (require 'mm-bodies)
+(require 'shr)
 (eval-when-compile (require 'cl-lib))
 
 (autoload 'gnus-map-function "gnus-util")
@@ -1841,8 +1842,6 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t)
           (let ((inhibit-read-only t))
             (delete-region min max))))))))
 
-(defvar shr-image-map)
-
 (autoload 'widget-convert-button "wid-edit")
 (defvar widget-keymap)
 
@@ -1856,7 +1855,10 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t)
        (widget-convert-button
         'url-link start end
         :help-echo (get-text-property start 'help-echo)
-        :keymap (setq keymap (copy-keymap shr-image-map))
+        :keymap (setq keymap (copy-keymap
+                              (if (mm--images-in-region-p start end)
+                                  shr-image-map
+                                shr-map)))
         (get-text-property start 'shr-url))
        ;; Mask keys that launch `widget-button-click'.
        ;; Those bindings are provided by `widget-keymap'
@@ -1872,6 +1874,19 @@ text/html;\\s-*charset=\\([^\t\n\r \"'>]+\\)[^>]*>" nil t)
          (overlay-put overlay 'face nil))
        (setq start end)))))
 
+(defun mm--images-in-region-p (start end)
+  (let ((found nil))
+    (save-excursion
+      (goto-char start)
+      (while (and (not found)
+                 (< (point) end))
+       (let ((display (get-text-property (point) 'display)))
+         (when (and (consp display)
+                    (eq (car display) 'image))
+           (setq found t)))
+       (forward-char 1)))
+    found))
+
 (defun mm-handle-filename (handle)
   "Return filename of HANDLE if any."
   (or (mail-content-type-get (mm-handle-type handle)