From 76e8d935a72c14037b44cff0a929b4f71b65bcf1 Mon Sep 17 00:00:00 2001
From: Stefan Kangas <stefankangas@gmail.com>
Date: Wed, 2 Sep 2020 23:10:27 +0200
Subject: [PATCH] Simplify mwheel-mode by using alist instead of two variables

* lisp/mwheel.el (mouse-wheel--remove-bindings): Update call
signature to take no arguments.  Doc fix.
(mouse-wheel--add-binding): Break out from...
(mouse-wheel-mode): ...here.  Simplify by using above functions.
(mouse-wheel--installed-bindings-alist): New variable.
(mwheel-installed-bindings): Make obsolete.
(mwheel-installed-text-scale-bindings): Make obsolete.
* test/lisp/mwheel-tests.el (mwheel-test-enable/disable):
New test.
---
 lisp/mwheel.el            | 49 ++++++++++++++++++++++-----------------
 test/lisp/mwheel-tests.el |  6 +++++
 2 files changed, 34 insertions(+), 21 deletions(-)

diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 53a5a50bada..3775eefc4f3 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -344,16 +344,24 @@ non-Windows systems."
                (text-scale-decrease 1)))
       (select-window selected-window))))
 
-(defvar mwheel-installed-bindings nil)
-(defvar mwheel-installed-text-scale-bindings nil)
+(defvar mouse-wheel--installed-bindings-alist nil
+  "Alist of all installed mouse wheel key bindings.")
 
-(defun mouse-wheel--remove-bindings (bindings funs)
-  "Remove key BINDINGS if they're bound to any function in FUNS.
-BINDINGS is a list of key bindings, FUNS is a list of functions.
+(defun mouse-wheel--add-binding (key fun)
+  "Bind mouse wheel button KEY to function FUN.
+Save it for later removal by `mouse-wheel--remove-bindings'."
+  (global-set-key key fun)
+  (push (cons key fun) mouse-wheel--installed-bindings-alist))
+
+(defun mouse-wheel--remove-bindings ()
+  "Remove all mouse wheel key bindings.
 This is a helper function for `mouse-wheel-mode'."
-  (dolist (key bindings)
-    (when (memq (lookup-key (current-global-map) key) funs)
-      (global-unset-key key))))
+  (dolist (binding mouse-wheel--installed-bindings-alist)
+    (let ((key (car binding))
+          (fun (cdr binding)))
+     (when (eq (lookup-key (current-global-map) key) fun)
+       (global-unset-key key))))
+  (setq mouse-wheel--installed-bindings-alist nil))
 
 (defun mouse-wheel--create-scroll-keys (binding event)
   "Return list of key vectors for BINDING and EVENT.
@@ -381,12 +389,7 @@ an event used for scrolling, such as `mouse-wheel-down-event'."
   :global t
   :group 'mouse
   ;; Remove previous bindings, if any.
-  (mouse-wheel--remove-bindings mwheel-installed-bindings
-                                '(mwheel-scroll))
-  (mouse-wheel--remove-bindings mwheel-installed-text-scale-bindings
-                                '(mouse-wheel-text-scale))
-  (setq mwheel-installed-bindings nil)
-  (setq mwheel-installed-text-scale-bindings nil)
+  (mouse-wheel--remove-bindings)
   ;; Setup bindings as needed.
   (when mouse-wheel-mode
     (dolist (binding mouse-wheel-scroll-amount)
@@ -394,18 +397,16 @@ an event used for scrolling, such as `mouse-wheel-down-event'."
        ;; Bindings for changing font size.
        ((and (consp binding) (eq (cdr binding) 'text-scale))
         (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event))
-          ;; Add binding.
-          (let ((key `[,(list (caar binding) event)]))
-            (global-set-key key 'mouse-wheel-text-scale)
-            (push key mwheel-installed-text-scale-bindings))))
+          (mouse-wheel--add-binding `[,(list (caar binding) event)]
+                                    'mouse-wheel-text-scale)))
        ;; Bindings for scrolling.
        (t
         (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
                              mouse-wheel-left-event mouse-wheel-right-event))
           (dolist (key (mouse-wheel--create-scroll-keys binding event))
-            ;; Add binding.
-            (global-set-key key 'mwheel-scroll)
-            (push key mwheel-installed-bindings))))))))
+            (mouse-wheel--add-binding key 'mwheel-scroll))))))))
+
+;;; Obsolete.
 
 ;;; Compatibility entry point
 ;; preloaded ;;;###autoload
@@ -414,6 +415,12 @@ an event used for scrolling, such as `mouse-wheel-down-event'."
   (declare (obsolete mouse-wheel-mode "27.1"))
   (mouse-wheel-mode (if uninstall -1 1)))
 
+(defvar mwheel-installed-bindings nil)
+(make-obsolete-variable 'mwheel-installed-bindings nil "28.1")
+
+(defvar mwheel-installed-text-scale-bindings nil)
+(make-obsolete-variable 'mwheel-installed-text-scale-bindings nil "28.1")
+
 (provide 'mwheel)
 
 ;;; mwheel.el ends here
diff --git a/test/lisp/mwheel-tests.el b/test/lisp/mwheel-tests.el
index 0e45b76c06e..fd998fd4f0e 100644
--- a/test/lisp/mwheel-tests.el
+++ b/test/lisp/mwheel-tests.el
@@ -22,6 +22,12 @@
 (require 'ert)
 (require 'mwheel)
 
+(ert-deftest mwheel-test-enable/disable ()
+  (mouse-wheel-mode 1)
+  (should (eq (lookup-key (current-global-map) '[mouse-4]) 'mwheel-scroll))
+  (mouse-wheel-mode -1)
+  (should (eq (lookup-key (current-global-map) '[mouse-4]) nil)))
+
 (ert-deftest mwheel-test--create-scroll-keys ()
   (should (equal (mouse-wheel--create-scroll-keys 10 'mouse-4)
                  '([mouse-4]
-- 
2.39.2