andros/emacs-gpu
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Simplify mwheel-mode by using alist instead of two variables

Browse source 
* 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.
This commit is contained in:
Stefan Kangas 2020-09-02 23:10:27 +02:00
parent 77a5b696bb
commit 76e8d935a7
2 changed files with 34 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

49
lisp/mwheel.el
View file

@ -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

6
test/lisp/mwheel-tests.el
View file

@ -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]