master 61fc4bf: Bind mwheel-scroll on more parts of frame's display

[Stefan Kangas]

branch: master
commit 61fc4bf286da9081b822e9280e351ce7045868dc
Author: Stefan Kangas <stefankangas@gmail.com>
Commit: Stefan Kangas <stefankangas@gmail.com>

    Bind mwheel-scroll on more parts of frame's display
    
    * lisp/mwheel.el (mouse-wheel-mode): Bind unmodified 'mwheel-scroll'
    on scroll bars, fringes, margins, header and mode line.  (Bug#5557)
    (mouse-wheel--create-scroll-keys): New helper function for
    'mouse-wheel-mode'.
    * test/lisp/mwheel-tests.el: New file.
---
 etc/NEWS                  |  7 +++++++
 lisp/mwheel.el            | 18 ++++++++++++++++--
 test/lisp/mwheel-tests.el | 38 ++++++++++++++++++++++++++++++++++++++
 3 files changed, 61 insertions(+), 2 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 0a6a7de..79b3aa3 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -102,6 +102,13 @@ deprecated.  Errors in the Inscript method were corrected.
 ** Rudimentary support for the 'st' terminal emulator.
 Emacs now supports 256 color display on the 'st' terminal emulator.
 
+---
+** Mouse wheel scrolling now works on more parts of frame's display.
+When using 'mwheel-mode', the mouse wheel will now scroll also when
+the mouse cursor is on the scroll bars, fringes, margins, header line,
+and mode line.  ('mwheel-mode' is enabled by default on most graphical
+displays.)
+
 
 * Editing Changes in Emacs 28.1
 
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 8e2039b..c385fdf 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -355,6 +355,18 @@ This is a helper function for `mouse-wheel-mode'."
     (when (memq (lookup-key (current-global-map) key) funs)
       (global-unset-key key))))
 
+(defun mouse-wheel--create-scroll-keys (binding event)
+  "Return list of key vectors for BINDING and EVENT.
+BINDING is an element in `mouse-wheel-scroll-amount'.  EVENT is
+an event used for scrolling, such as `mouse-wheel-down-event'."
+  (let ((prefixes (list 'left-margin 'right-margin
+                        'left-fringe 'right-fringe
+                        'vertical-scroll-bar 'horizontal-scroll-bar
+                        'mode-line 'header-line)))
+    (cons (vector event)                  ; default case: no prefix.
+          (when (not (consp binding))
+            (mapcar (lambda (prefix) (vector prefix event)) prefixes)))))
+
 (define-minor-mode mouse-wheel-mode
   "Toggle mouse wheel support (Mouse Wheel mode)."
   :init-value t
@@ -379,14 +391,16 @@ This is a helper function for `mouse-wheel-mode'."
        ;; 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))))
        ;; Bindings for scrolling.
        (t
         (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
-                             mouse-wheel-right-event mouse-wheel-left-event))
-          (let ((key `[(,@(if (consp binding) (car binding)) ,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))))))))
 
diff --git a/test/lisp/mwheel-tests.el b/test/lisp/mwheel-tests.el
new file mode 100644
index 0000000..f2989d6
--- /dev/null
+++ b/test/lisp/mwheel-tests.el
@@ -0,0 +1,38 @@
+;;; mwheel-tests.el --- tests for mwheel.el  -*- lexical-binding:t -*-
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'mwheel)
+
+(ert-deftest mwheel-test--create-scroll-keys ()
+  (should (equal (mouse-wheel--create-scroll-keys 10 'mouse-1)
+                 '([mouse-1]
+                   [left-margin mouse-1] [right-margin mouse-1]
+                   [left-fringe mouse-1] [right-fringe mouse-1]
+                   [vertical-scroll-bar mouse-1] [horizontal-scroll-bar 
mouse-1]
+                   [mode-line mouse-1] [header-line mouse-1])))
+  ;; Don't bind modifiers outside of buffer area (e.g. for fringes).
+  (should (equal (mouse-wheel--create-scroll-keys '((shift) . 1) 'mouse-1)
+                 '([mouse-1])))
+  (should (equal (mouse-wheel--create-scroll-keys '((control) . 9) 'mouse-7)
+                 '([mouse-7]))))
+
+;;; mwheel-tests.el ends here