From 61fc4bf286da9081b822e9280e351ce7045868dc Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Sat, 22 Aug 2020 13:21:13 +0200 Subject: [PATCH] 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(-) create mode 100644 test/lisp/mwheel-tests.el diff --git a/etc/NEWS b/etc/NEWS index 0a6a7dec5cd..79b3aa37320 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 8e2039ba9d8..c385fdfc265 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 00000000000..f2989d608b4 --- /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 . + +;;; 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 -- 2.39.2