From 4575ae5a9c5589ac903362486951f0d36c8ff8ee Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 13 Apr 2018 23:49:58 +0200 Subject: [PATCH] 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. --- lisp/gnus/mm-decode.el | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 7ab84c0c83d..d8753e5a1d5 100644 --- 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) -- 2.11.4.GIT