From: Stefan Kangas <stefan@marxist.se>
To: Eli Zaretskii <eliz@gnu.org>
Cc: 5557@debbugs.gnu.org, larsi@gnus.org, lennart.borgman@gmail.com
Subject: bug#5557: <left-margin> <double-wheel-down> is undefined
Date: Sat, 22 Aug 2020 07:48:31 -0400 [thread overview]
Message-ID: <CADwFkmk98XhaJeFOtkm2nEJkdAU2oqLzpLs=4vLQiSj1dP5NLw@mail.gmail.com> (raw)
In-Reply-To: <83r1rz9lvp.fsf@gnu.org>
[-- Attachment #1: Type: text/plain, Size: 565 bytes --]
Eli Zaretskii <eliz@gnu.org> writes:
>> +*** Mouse wheel scrolling less sensitive to positioning.
>
> I'd suggest
>
> Mouse-wheel scrolling now works on more parts of frame's display.
>
>> +When using 'mwheel-mode' (enabled by default), the mouse wheel will
>> +now scroll also when the mouse cursor is on the fringe, margin, header
>> +line, and mode line.
>
> The code also arranges for the scroll bars, no? Also, please use
> "fringes" and "margins", in plural.
Thanks for the review. Fixed your comments in the attached patch.
Best regards,
Stefan Kangas
[-- Attachment #2: 0001-Bind-mwheel-scroll-on-more-parts-of-frame-s-display.patch --]
[-- Type: text/x-diff, Size: 5204 bytes --]
From 61fc4bf286da9081b822e9280e351ce7045868dc Mon Sep 17 00:00:00 2001
From: Stefan Kangas <stefankangas@gmail.com>
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 0a6a7dec5c..79b3aa3732 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.)
+
\f
* Editing Changes in Emacs 28.1
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 8e2039ba9d..c385fdfc26 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -355,6 +355,18 @@ mouse-wheel--remove-bindings
(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 @@ 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 0000000000..f2989d608b
--- /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
--
2.28.0
next prev parent reply other threads:[~2020-08-22 11:48 UTC|newest]
Thread overview: 29+ messages / expand[flat|nested] mbox.gz Atom feed top
2010-02-10 13:01 bug#5557: <left-margin> <double-wheel-down> is undefined Lennart Borgman
2019-10-01 15:36 ` Lars Ingebrigtsen
2019-10-01 16:09 ` Eli Zaretskii
2019-10-01 16:19 ` Lars Ingebrigtsen
2019-10-01 16:26 ` Eli Zaretskii
2019-10-01 16:32 ` Lars Ingebrigtsen
2019-10-01 16:36 ` Eli Zaretskii
2019-10-01 17:39 ` Stefan Kangas
2019-10-01 18:31 ` Eli Zaretskii
2019-10-01 18:43 ` Stefan Kangas
2019-10-01 19:06 ` Eli Zaretskii
2019-10-02 8:55 ` martin rudalics
2019-10-03 15:35 ` Lars Ingebrigtsen
2019-10-03 18:11 ` martin rudalics
2020-08-13 5:34 ` Stefan Kangas
2020-08-13 8:42 ` Lars Ingebrigtsen
2020-08-13 13:06 ` Eli Zaretskii
2020-08-14 18:38 ` Stefan Kangas
2020-08-14 19:13 ` Eli Zaretskii
2020-08-14 21:34 ` Stefan Kangas
2020-08-15 17:40 ` Eli Zaretskii
2020-08-16 13:41 ` Stefan Kangas
2020-08-16 14:48 ` Eli Zaretskii
2020-08-16 15:57 ` Stefan Kangas
2020-08-17 13:30 ` Stefan Kangas
2020-08-22 7:32 ` Eli Zaretskii
2020-08-22 11:48 ` Stefan Kangas [this message]
2020-08-22 11:59 ` Eli Zaretskii
2020-08-22 12:11 ` Stefan Kangas
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to='CADwFkmk98XhaJeFOtkm2nEJkdAU2oqLzpLs=4vLQiSj1dP5NLw@mail.gmail.com' \
--to=stefan@marxist.se \
--cc=5557@debbugs.gnu.org \
--cc=eliz@gnu.org \
--cc=larsi@gnus.org \
--cc=lennart.borgman@gmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).