master 54d3de64e19 6/6: Merge branch 'mwheel-no-alts'

[Stefan Monnier]

branch: master
commit 54d3de64e1902402a8e7dbb2991f360397281a9e
Merge: 3add626f140 998667f9026
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    Merge branch 'mwheel-no-alts'
---
 doc/lispref/commands.texi  |  29 ++++----
 etc/NEWS                   |   7 ++
 lisp/completion-preview.el |  16 ++---
 lisp/edmacro.el            |  16 ++---
 lisp/keymap.el             |  12 +++-
 lisp/mwheel.el             | 166 ++++++++++++++++-----------------------------
 test/src/keymap-tests.el   |  17 +++--
 7 files changed, 119 insertions(+), 144 deletions(-)

diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi
index 10f47d736d2..5f840ac21ec 100644
--- a/doc/lispref/commands.texi
+++ b/doc/lispref/commands.texi
@@ -2562,23 +2562,24 @@ non-@code{nil}.
 @vindex mouse-wheel-up-event
 @vindex mouse-wheel-down-event
 The @code{wheel-up} and @code{wheel-down} events are generated only on
-some kinds of systems.  On other systems, @code{mouse-4} and
-@code{mouse-5} are used instead.  For portable code, use the variables
-@code{mouse-wheel-up-event}, @code{mouse-wheel-up-alternate-event},
-@code{mouse-wheel-down-event} and
-@code{mouse-wheel-down-alternate-event} defined in @file{mwheel.el} to
-determine what event types to expect from the mouse wheel.
+some kinds of systems.  On other systems, other events like @code{mouse-4} and
+@code{mouse-5} are used instead.  Portable code should handle both
+@code{wheel-up} and @code{wheel-down} events as well as the events
+specified in the variables @code{mouse-wheel-up-event} and
+@code{mouse-wheel-down-event}, defined in @file{mwheel.el}.
 
 @vindex mouse-wheel-left-event
 @vindex mouse-wheel-right-event
-Similarly, some mice can generate @code{mouse-wheel-left-event} and
-@code{mouse-wheel-right-event} and can be used to scroll if
-@code{mouse-wheel-tilt-scroll} is non-@code{nil}.  However, some mice
-also generate other events at the same time as they're generating
-these scroll events which may get in the way.  The way to fix this is
-generally to unbind these events (for instance, @code{mouse-6} or
-@code{mouse-7}, but this is very hardware and operating system
-dependent).
+The same holds for the  horizontal wheel movements which are usually
+represented by @code{wheel-left} and @code{wheel-right} events, but
+for which portable code should also obey the variables
+@code{mouse-wheel-left-event} and @code{mouse-wheel-right-event},
+defined in @file{mwheel.el}.
+However, some mice also generate other events at the same time as
+they're generating these scroll events which may get in the way.
+The way to fix this is generally to unbind these events (for instance,
+@code{mouse-6} or @code{mouse-7}, but this is very hardware and
+operating system dependent).
 
 @cindex @code{pinch} event
 @item (pinch @var{position} @var{dx} @var{dy} @var{scale} @var{angle})
diff --git a/etc/NEWS b/etc/NEWS
index 967d8a94113..8129412e872 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -416,6 +416,13 @@ respectively, in addition to the existing translations 
'C-x 8 / e' and
 ** Trace
 In batch mode, tracing now sends the trace to stdout.
 
++++
+** Mwheel
+The 'wheel-up/down/left/right' events are now bound unconditionally,
+and the 'mouse-wheel-up/down/left/right-event' variables are thus
+used only to specify the 'mouse-4/5/6/7' events generated by
+legacy setup, such as 'xterm-mouse-mode' or X11 without XInput2.
+
 +++
 ** New command 'lldb'.
 Run the LLDB debugger, analogous to the 'gud-gdb' command.
diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
index baadb4714b1..f552db7aa8e 100644
--- a/lisp/completion-preview.el
+++ b/lisp/completion-preview.el
@@ -52,6 +52,8 @@
 
 ;;; Code:
 
+(require 'mwheel)
+
 (defgroup completion-preview nil
   "In-buffer completion preview."
   :group 'completion)
@@ -128,19 +130,17 @@ If this option is nil, these commands do not display any 
message."
   ;; "M-p" #'completion-preview-prev-candidate
   )
 
-(defvar mouse-wheel-up-event)
-(defvar mouse-wheel-up-alternate-event)
-(defvar mouse-wheel-down-event)
-(defvar mouse-wheel-down-alternate-event)
 (defvar-keymap completion-preview--mouse-map
   :doc "Keymap for mouse clicks on the completion preview."
   "<down-mouse-1>" #'completion-preview-insert
   "C-<down-mouse-1>" #'completion-at-point
   "<down-mouse-2>" #'completion-at-point
-  (format "<%s>" mouse-wheel-up-event)             
#'completion-preview-prev-candidate
-  (format "<%s>" mouse-wheel-up-alternate-event)   
#'completion-preview-prev-candidate
-  (format "<%s>" mouse-wheel-down-event)           
#'completion-preview-next-candidate
-  (format "<%s>" mouse-wheel-down-alternate-event) 
#'completion-preview-next-candidate)
+  "<wheel-up>"     #'completion-preview-prev-candidate
+  "<wheel-down>"   #'completion-preview-next-candidate
+  (key-description (vector mouse-wheel-up-event))
+  #'completion-preview-prev-candidate
+  (key-description (vector mouse-wheel-down-event))
+  #'completion-preview-next-candidate)
 
 (defvar-local completion-preview--overlay nil)
 
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index 362ec0ecbb4..9d185d79142 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -720,17 +720,15 @@ This function assumes that the events can be stored in a 
string."
            (setf (aref seq i) (logand (aref seq i) 127)))
   seq)
 
-;; These are needed in a --without-x build.
-(defvar mouse-wheel-down-event)
-(defvar mouse-wheel-up-event)
-(defvar mouse-wheel-right-event)
-(defvar mouse-wheel-left-event)
-
 (defun edmacro-fix-menu-commands (macro &optional noerror)
   (if (vectorp macro)
       (let (result)
         ;; Not preloaded in a --without-x build.
         (require 'mwheel)
+        (defvar mouse-wheel-down-event)
+        (defvar mouse-wheel-up-event)
+        (defvar mouse-wheel-right-event)
+        (defvar mouse-wheel-left-event)
        ;; Make a list of the elements.
        (setq macro (append macro nil))
        (dolist (ev macro)
@@ -746,9 +744,9 @@ This function assumes that the events can be stored in a 
string."
                ;; info is recorded in macros to make this possible.
                ((or (mouse-event-p ev) (mouse-movement-p ev)
                     (memq (event-basic-type ev)
-                          (list mouse-wheel-down-event mouse-wheel-up-event
-                                mouse-wheel-right-event
-                                mouse-wheel-left-event)))
+                          `( ,mouse-wheel-down-event ,mouse-wheel-up-event
+                             ,mouse-wheel-right-event ,mouse-wheel-left-event
+                             wheel-down wheel-up wheel-left wheel-right)))
                 nil)
                (noerror nil)
                (t
diff --git a/lisp/keymap.el b/lisp/keymap.el
index 065c59da74c..d2544e30ce0 100644
--- a/lisp/keymap.el
+++ b/lisp/keymap.el
@@ -577,9 +577,15 @@ should be a MENU form as accepted by `easy-menu-define'.
           (let ((def (pop definitions)))
             (if (eq key :menu)
                 (easy-menu-define nil keymap "" def)
-              (if (member key seen-keys)
-                  (error "Duplicate definition for key: %S %s" key keymap)
-                (push key seen-keys))
+              (when (member key seen-keys)
+                ;; Since the keys can be computed dynamically, it can
+                ;; very well happen that we get duplicate definitions
+                ;; due to some unfortunate configuration rather than
+                ;; due to an actual bug.  While such duplicates are
+                ;; not desirable, they shouldn't prevent the users
+                ;; from getting their job done.
+                (message "Duplicate definition for key: %S %s" key keymap))
+              (push key seen-keys)
               (keymap-set keymap key def)))))
       keymap)))
 
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index b75b6f27d53..fc1f8e8b6d6 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -56,49 +56,33 @@
              (bound-and-true-p mouse-wheel-mode))
     (mouse-wheel-mode 1)))
 
-(defcustom mouse-wheel-down-event
+(defvar mouse-wheel-obey-old-style-wheel-buttons
+  ;; FIXME: Yuck!
   (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."
-  :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."
+      (if (featurep 'xinput2)
+          nil
+        (unless (featurep 'x)
+          t))
+    t)
+  "If non-nil, treat mouse-4/5/6/7 events as mouse wheel events.
+These are the event names used historically in X11 before XInput2.
+They are sometimes generated by things like `xterm-mouse-mode' as well.")
+
+(defcustom mouse-wheel-down-event
+  (if mouse-wheel-obey-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."
-  :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."
+  (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-5)
+  "Event used for scrolling up, beside `wheel-up', if any."
   :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 +92,7 @@ scrolling with the mouse wheel.  To prevent that, this 
variable can be
 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 +149,7 @@ information, see `text-scale-adjust' and 
`global-text-scale-adjust'."
                     (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 +200,9 @@ Also see `mouse-wheel-tilt-scroll'."
   :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 @@ Also see `mouse-wheel-tilt-scroll'."
   "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-obey-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-obey-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 @@ active 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,17 @@ value of ARG, and the command uses it in subsequent 
scrolls."
     (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 +336,30 @@ 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) (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))
+                    ((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 +397,12 @@ See also `text-scale-adjust'."
   (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 +411,10 @@ See also `text-scale-adjust'."
   "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 +466,13 @@ 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
-                           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 +480,7 @@ an event used for scrolling, such as 
`mouse-wheel-down-event'."
      (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))))))))
diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el
index bc9977f31bf..04b897045db 100644
--- a/test/src/keymap-tests.el
+++ b/test/src/keymap-tests.el
@@ -23,6 +23,7 @@
 ;;; Code:
 
 (require 'ert)
+(require 'cl-lib)
 
 (defun keymap-tests--make-keymap-test (fun)
   (should (eq (car (funcall fun)) 'keymap))
@@ -470,10 +471,18 @@ g .. h            foo
        ert-keymap-duplicate
        "a" #'next-line
        "a" #'previous-line))
-  (should-error
-   (define-keymap
-       "a" #'next-line
-       "a" #'previous-line)))
+  (let ((msg ""))
+    ;; FIXME: It would be nicer to use `current-message' rather than override
+    ;; `message', but `current-message' returns always nil in batch mode :-(
+    (cl-letf (((symbol-function 'message)
+               (lambda (fmt &rest args) (setq msg (apply #'format fmt args)))))
+      (should
+       (string-match "duplicate"
+                     (progn
+                       (define-keymap
+                         "a" #'next-line
+                         "a" #'previous-line)
+                       msg))))))
 
 (ert-deftest keymap-unset-test-remove-and-inheritance ()
   "Check various behaviors of keymap-unset.  (Bug#62207)"