Merge remote-tracking branch 'origin/master' into feature/pgtk

1 files changed, 83 insertions, 54 deletions

diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 4627142757b..d04139d1489 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -55,29 +55,47 @@
     (mouse-wheel-mode 1)))
 
 (defcustom mouse-wheel-down-event
-  (cond ((or (featurep 'w32-win) (featurep 'ns-win))
-         'wheel-up)
-        ((featurep 'pgtk-win)
-         '(mouse-4 wheel-up))
-        (t
-         'mouse-4))
+  (if (or (featurep 'w32-win) (featurep 'ns-win)
+          (featurep 'haiku-win) (featurep 'pgtk-win))
+      'wheel-up
+    'mouse-4)
   "Event used for scrolling down."
   :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."
+  :group 'mouse
+  :type 'symbol
+  :version "29.1"
+  :set 'mouse-wheel-change-button)
+
 (defcustom mouse-wheel-up-event
-  (cond ((or (featurep 'w32-win) (featurep 'ns-win))
-         'wheel-down)
-        ((featurep 'pgtk-win)
-         '(mouse-5 wheel-down))
-        (t
-         'mouse-5))
+  (if (or (featurep 'w32-win) (featurep 'ns-win)
+          (featurep 'haiku-win) (feautrep 'pgtk-win))
+      'wheel-down
+    'mouse-5)
   "Event used for scrolling up."
   :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)
+
 (defcustom mouse-wheel-click-event 'mouse-2
   "Event that should be temporarily inhibited after mouse scrolling.
 The mouse wheel is typically on the mouse-2 button, so it may easily
@@ -227,23 +245,33 @@ Also see `mouse-wheel-tilt-scroll'."
   "Function that does the job of scrolling right.")
 
 (defvar mouse-wheel-left-event
-  (cond ((or (featurep 'w32-win) (featurep 'ns-win))
-         'wheel-left)
-        ((featurep 'pgtk-win)
-         '(mouse-6 wheel-left))
-        (t
-         'mouse-6))
+  (if (or (featurep 'w32-win) (featurep 'ns-win)
+          (featurep 'haiku-win) (featurep 'pgtk-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-8))
+  "Alternative wheel left event to consider.")
+
 (defvar mouse-wheel-right-event
-  (cond ((or (featurep 'w32-win) (featurep 'ns-win))
-         'wheel-right)
-        ((featurep 'pgtk-win)
-         '(mouse-7 wheel-right))
-        (t
-         'mouse-7))
+  (if (or (featurep 'w32-win) (featurep 'ns-win)
+          (featurep 'haiku-win) (featurep 'pgtk-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.")
+
 (defun mouse-wheel--get-scroll-window (event)
   "Return window for mouse wheel event EVENT.
 If `mouse-wheel-follow-mouse' is non-nil, return the window that
@@ -271,18 +299,6 @@ active window."
                frame nil t)))))
       (mwheel-event-window event)))
 
-(defun mouse-wheel--button-eq (btn lst)
-  "Test whether BTN is included in LST."
-  (cond ((listp lst)
-         (memq btn lst))
-        (t
-         (eq lst btn))
-        ))
-
-(defun mouse-wheel--button-flatten (&rest arg)
-  "Flatten ARG."
-  (flatten-list arg))
-
 (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
@@ -320,14 +336,16 @@ value of ARG, and the command uses it in subsequent scrolls."
     (condition-case nil
         (unwind-protect
 	    (let ((button (mwheel-event-button event)))
-              (cond ((and (eq amt 'hscroll) (mouse-wheel--button-eq button mouse-wheel-down-event))
+              (cond ((and (eq amt 'hscroll) (memq button (list mouse-wheel-down-event
+                                                               mouse-wheel-down-alternate-event)))
                      (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))
-                    ((mouse-wheel--button-eq button mouse-wheel-down-event)
+                    ((memq button (list mouse-wheel-down-event
+                                        mouse-wheel-down-alternate-event))
                      (condition-case nil (funcall mwheel-scroll-down-function amt)
                        ;; Make sure we do indeed scroll to the beginning of
                        ;; the buffer.
@@ -342,23 +360,27 @@ value of ARG, and the command uses it in subsequent scrolls."
                           ;; 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) (mouse-wheel--button-eq button mouse-wheel-up-event))
+                    ((and (eq amt 'hscroll) (memq button (list mouse-wheel-up-event
+                                                               mouse-wheel-up-alternate-event)))
                      (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))
-                    ((mouse-wheel--button-eq button mouse-wheel-up-event)
+                    ((memq button (list mouse-wheel-up-event
+                                        mouse-wheel-up-alternate-event))
                      (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)))))
-                    ((eq button mouse-wheel-left-event) ; for tilt scroll
+                    ((memq button (list mouse-wheel-left-event
+                                        mouse-wheel-left-alternate-event)) ; for tilt scroll
                      (when mouse-wheel-tilt-scroll
                        (funcall (if mouse-wheel-flip-direction
                                     mwheel-scroll-right-function
                                   mwheel-scroll-left-function) amt)))
-                    ((eq button mouse-wheel-right-event) ; for tilt scroll
+                    ((memq button (list mouse-wheel-right-event
+                                        mouse-wheel-right-alternate-event)) ; for tilt scroll
                      (when mouse-wheel-tilt-scroll
                        (funcall (if mouse-wheel-flip-direction
                                     mwheel-scroll-left-function
@@ -402,9 +424,11 @@ value of ARG, and the command uses it in subsequent scrolls."
         (button (mwheel-event-button event)))
     (select-window scroll-window 'mark-for-redisplay)
     (unwind-protect
-        (cond ((mouse-wheel--button-eq button mouse-wheel-down-event)
+        (cond ((memq button (list mouse-wheel-down-event
+                                  mouse-wheel-down-alternate-event))
                (text-scale-increase 1))
-              ((mouse-wheel--button-eq button mouse-wheel-up-event)
+              ((memq button (list mouse-wheel-up-event
+                                  mouse-wheel-up-alternate-event))
                (text-scale-decrease 1)))
       (select-window selected-window))))
 
@@ -456,18 +480,23 @@ an event used for scrolling, such as `mouse-wheel-down-event'."
     (cond
      ;; Bindings for changing font size.
      ((and (consp binding) (eq (cdr binding) 'text-scale))
-      (dolist (event (mouse-wheel--button-flatten mouse-wheel-down-event
-                                                 mouse-wheel-up-event))
-        (mouse-wheel--add-binding `[,(list (caar binding) event)]
-                                  'mouse-wheel-text-scale)))
+      (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
+                           mouse-wheel-down-alternate-event
+                           mouse-wheel-up-alternate-event))
+        (when event
+          (mouse-wheel--add-binding `[,(list (caar binding) event)]
+                                    'mouse-wheel-text-scale))))
      ;; Bindings for scrolling.
      (t
-      (dolist (event (mouse-wheel--button-flatten 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))
-          (mouse-wheel--add-binding key 'mwheel-scroll)))))))
+      (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))
+        (when event
+          (dolist (key (mouse-wheel--create-scroll-keys binding event))
+            (mouse-wheel--add-binding key 'mwheel-scroll))))))))
 
 (when mouse-wheel-mode
   (mouse-wheel--setup-bindings))