diff --git a/lisp/mwheel.el b/lisp/mwheel.el index b75b6f27d53..ca6d3cccb97 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -56,49 +56,32 @@ mouse-wheel-change-button (bound-and-true-p mouse-wheel-mode)) (mouse-wheel-mode 1))) -(defcustom mouse-wheel-down-event - (if (or (featurep 'w32-win) (featurep 'ns-win) - (featurep 'haiku-win) (featurep 'pgtk-win) - (featurep 'android-win)) - 'wheel-up - 'mouse-4) - "Event used for scrolling down." +(defcustom mouse-wheel-use-old-style-wheel-buttons + ;; FIXME: Is this ever non-nil in practice? + (not (and (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win) (featurep 'pgtk-win) + (featurep 'android-win)) + (or (featurep 'xinput2) + (featurep 'x)))) + "If non-nil, treat mouse-4/5/6/7 as wheel buttons. +These are the event names used historically in X11 before XInput2. +They are sometimes used by things like `xterm-mouse-mode' as well." :group 'mouse - :type 'symbol - :set 'mouse-wheel-change-button) - -(defcustom mouse-wheel-down-alternate-event - (if (featurep 'xinput2) - 'wheel-up - (unless (featurep 'x) - 'mouse-4)) - "Alternative wheel down event to consider." + :type 'boolean) + +(defcustom mouse-wheel-down-event + (if mouse-wheel-use-old-style-wheel-buttons 'mouse-4) + "Event used for scrolling down, beside `wheel-down', if any." :group 'mouse :type 'symbol - :version "29.1" - :set 'mouse-wheel-change-button) + :set #'mouse-wheel-change-button) (defcustom mouse-wheel-up-event - (if (or (featurep 'w32-win) (featurep 'ns-win) - (featurep 'haiku-win) (featurep 'pgtk-win) - (featurep 'android-win)) - 'wheel-down - 'mouse-5) - "Event used for scrolling up." + (if mouse-wheel-use-old-style-wheel-buttons 'mouse-5) + "Event used for scrolling up, beside `wheel-up', if any." :group 'mouse :type 'symbol - :set 'mouse-wheel-change-button) - -(defcustom mouse-wheel-up-alternate-event - (if (featurep 'xinput2) - 'wheel-down - (unless (featurep 'x) - 'mouse-5)) - "Alternative wheel up event to consider." - :group 'mouse - :type 'symbol - :version "29.1" - :set 'mouse-wheel-change-button) + :set #'mouse-wheel-change-button) (defcustom mouse-wheel-click-event 'mouse-2 "Event that should be temporarily inhibited after mouse scrolling. @@ -108,7 +91,7 @@ mouse-wheel-click-event set to the event sent when clicking on the mouse wheel button." :group 'mouse :type 'symbol - :set 'mouse-wheel-change-button) + :set #'mouse-wheel-change-button) (defcustom mouse-wheel-inhibit-click-time 0.35 "Time in seconds to inhibit clicking on mouse wheel button after scroll." @@ -165,7 +148,7 @@ mouse-wheel-scroll-amount (const :tag "Scroll horizontally" :value hscroll) (const :tag "Change buffer face size" :value text-scale) (const :tag "Change global face size" :value global-text-scale))))) - :set 'mouse-wheel-change-button + :set #'mouse-wheel-change-button :version "28.1") (defcustom mouse-wheel-progressive-speed t @@ -216,15 +199,10 @@ mouse-wheel-flip-direction :type 'boolean :version "26.1") -(defun mwheel-event-button (event) - (let ((x (event-basic-type event))) - ;; Map mouse-wheel events to appropriate buttons - (if (eq 'mouse-wheel x) - (let ((amount (car (cdr (cdr (cdr event)))))) - (if (< amount 0) - mouse-wheel-up-event - mouse-wheel-down-event)) - x))) + +;; This function used to handle the `mouse-wheel` event which was +;; removed in 2003 by commit 9eb28007fb27, thus making it obsolete. +(define-obsolete-function-alias 'mwheel-event-button #'event-basic-type "30.1") (defun mwheel-event-window (event) (posn-window (event-start event))) @@ -255,34 +233,12 @@ mwheel-scroll-right-function "Function that does the job of scrolling right.") (defvar mouse-wheel-left-event - (if (or (featurep 'w32-win) (featurep 'ns-win) - (featurep 'haiku-win) (featurep 'pgtk-win) - (featurep 'android-win)) - 'wheel-left - 'mouse-6) - "Event used for scrolling left.") - -(defvar mouse-wheel-left-alternate-event - (if (featurep 'xinput2) - 'wheel-left - (unless (featurep 'x) - 'mouse-6)) - "Alternative wheel left event to consider.") + (if mouse-wheel-use-old-style-wheel-buttons 'mouse-6) + "Event used for scrolling left, beside `wheel-left', if any.") (defvar mouse-wheel-right-event - (if (or (featurep 'w32-win) (featurep 'ns-win) - (featurep 'haiku-win) (featurep 'pgtk-win) - (featurep 'android-win)) - 'wheel-right - 'mouse-7) - "Event used for scrolling right.") - -(defvar mouse-wheel-right-alternate-event - (if (featurep 'xinput2) - 'wheel-right - (unless (featurep 'x) - 'mouse-7)) - "Alternative wheel right event to consider.") + (if mouse-wheel-use-old-style-wheel-buttons 'mouse-7) + "Event used for scrolling right, beside `wheel-right', if any.") (defun mouse-wheel--get-scroll-window (event) "Return window for mouse wheel event EVENT. @@ -311,6 +267,15 @@ mouse-wheel--get-scroll-window frame nil t))))) (mwheel-event-window event))) +(defmacro mwheel--is-dir-p (dir button) + (declare (debug (sexp form))) + (let ((custom-var (intern (format "mouse-wheel-%s-event" dir))) + (event (intern (format "wheel-%s" dir)))) + (macroexp-let2 nil butsym button + `(or (eq ,butsym ',event) + ;; We presume here `button' is never nil. + (eq ,butsym ,custom-var))))) + (defun mwheel-scroll (event &optional arg) "Scroll up or down according to the EVENT. This should be bound only to mouse buttons 4, 5, 6, and 7 on @@ -347,18 +312,18 @@ mwheel-scroll (when (numberp amt) (setq amt (* amt (event-line-count event)))) (condition-case nil (unwind-protect - (let ((button (mwheel-event-button event))) - (cond ((and (eq amt 'hscroll) (memq button (list mouse-wheel-down-event - mouse-wheel-down-alternate-event))) + (let ((button (event-basic-type event))) + (cond ((and (eq amt 'hscroll) + (mwheel--is-dir-p down button)) (when (and (natnump arg) (> arg 0)) (setq mouse-wheel-scroll-amount-horizontal arg)) (funcall (if mouse-wheel-flip-direction mwheel-scroll-left-function mwheel-scroll-right-function) mouse-wheel-scroll-amount-horizontal)) - ((memq button (list mouse-wheel-down-event - mouse-wheel-down-alternate-event)) - (condition-case nil (funcall mwheel-scroll-down-function amt) + ((mwheel--is-dir-p down button) + (condition-case nil + (funcall mwheel-scroll-down-function amt) ;; Make sure we do indeed scroll to the beginning of ;; the buffer. (beginning-of-buffer @@ -372,31 +337,32 @@ mwheel-scroll ;; for a reason that escapes me. This problem seems ;; to only affect scroll-down. --Stef (set-window-start (selected-window) (point-min)))))) - ((and (eq amt 'hscroll) (memq button (list mouse-wheel-up-event - mouse-wheel-up-alternate-event))) + ((and (eq amt 'hscroll) + (mwheel--is-dir-p up button)) (when (and (natnump arg) (> arg 0)) (setq mouse-wheel-scroll-amount-horizontal arg)) (funcall (if mouse-wheel-flip-direction mwheel-scroll-right-function mwheel-scroll-left-function) mouse-wheel-scroll-amount-horizontal)) - ((memq button (list mouse-wheel-up-event - mouse-wheel-up-alternate-event)) - (condition-case nil (funcall mwheel-scroll-up-function amt) + ((mwheel--is-dir-p up button) + (condition-case nil + (funcall mwheel-scroll-up-function amt) ;; Make sure we do indeed scroll to the end of the buffer. - (end-of-buffer (while t (funcall mwheel-scroll-up-function))))) - ((memq button (list mouse-wheel-left-event - mouse-wheel-left-alternate-event)) ; for tilt scroll + (end-of-buffer + (while t (funcall mwheel-scroll-up-function))))) + ((mwheel--is-dir-p left button) ; for tilt scroll (when mouse-wheel-tilt-scroll (funcall (if mouse-wheel-flip-direction mwheel-scroll-right-function - mwheel-scroll-left-function) amt))) - ((memq button (list mouse-wheel-right-event - mouse-wheel-right-alternate-event)) ; for tilt scroll + mwheel-scroll-left-function) + amt))) + ((mwheel--is-dir-p right button) ; for tilt scroll (when mouse-wheel-tilt-scroll (funcall (if mouse-wheel-flip-direction mwheel-scroll-left-function - mwheel-scroll-right-function) amt))) + mwheel-scroll-right-function) + amt))) (t (error "Bad binding in mwheel-scroll")))) (if (eq scroll-window selected-window) ;; If there is a temporarily active region, deactivate it if @@ -434,14 +400,12 @@ mouse-wheel-text-scale (interactive (list last-input-event)) (let ((selected-window (selected-window)) (scroll-window (mouse-wheel--get-scroll-window event)) - (button (mwheel-event-button event))) + (button (event-basic-type event))) (select-window scroll-window 'mark-for-redisplay) (unwind-protect - (cond ((memq button (list mouse-wheel-down-event - mouse-wheel-down-alternate-event)) + (cond ((mwheel--is-dir-p down button) (text-scale-increase 1)) - ((memq button (list mouse-wheel-up-event - mouse-wheel-up-alternate-event)) + ((mwheel--is-dir-p up button) (text-scale-decrease 1))) (select-window selected-window)))) @@ -450,12 +414,10 @@ mouse-wheel-global-text-scale "Increase or decrease the global font size according to the EVENT. This invokes `global-text-scale-adjust', which see." (interactive (list last-input-event)) - (let ((button (mwheel-event-button event))) - (cond ((memq button (list mouse-wheel-down-event - mouse-wheel-down-alternate-event)) + (let ((button (event-basic-type event))) + (cond ((mwheel--is-dir-p down button) (global-text-scale-adjust 1)) - ((memq button (list mouse-wheel-up-event - mouse-wheel-up-alternate-event)) + ((mwheel--is-dir-p up button) (global-text-scale-adjust -1))))) (defun mouse-wheel--add-binding (key fun) @@ -507,15 +469,13 @@ mouse-wheel--setup-bindings ;; Bindings for changing font size. ((and (consp binding) (eq (cdr binding) 'text-scale)) (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event - mouse-wheel-down-alternate-event - mouse-wheel-up-alternate-event)) + 'wheel-down 'wheel-up)) (when event (mouse-wheel--add-binding `[,(append (car binding) (list event))] 'mouse-wheel-text-scale)))) ((and (consp binding) (eq (cdr binding) 'global-text-scale)) (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event - mouse-wheel-down-alternate-event - mouse-wheel-up-alternate-event)) + 'wheel-down 'wheel-up)) (when event (mouse-wheel--add-binding `[,(append (car binding) (list event))] 'mouse-wheel-global-text-scale)))) @@ -523,10 +483,7 @@ mouse-wheel--setup-bindings (t (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event mouse-wheel-left-event mouse-wheel-right-event - mouse-wheel-down-alternate-event - mouse-wheel-up-alternate-event - mouse-wheel-left-alternate-event - mouse-wheel-right-alternate-event)) + 'wheel-down 'wheel-up 'wheel-left 'wheel-right)) (when event (dolist (key (mouse-wheel--create-scroll-keys binding event)) (mouse-wheel--add-binding key 'mwheel-scroll))))))))