>From 60e6903ae12546db93f149b1f184ffc7ccdc30c2 Mon Sep 17 00:00:00 2001
From: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Mon, 29 Jan 2024 09:35:09 -0500
Subject: [PATCH] xterm.c: Map old-style wheel buttons to actual wheel events

Change the handling of the old X11 convention to use mouse-4/5/6/7
events to represent wheel events: instead of asking downstream
packages to use the `mouse-wheel-*-event` variables to know which events
represent wheel events, use those variables in `xterm.c` to directly
convert those events into the standard `wheel-up/down/left/right` events
used everywhere else.

This simplifies the work of packages which can now just bind their
commands to `wheel-up/down/left/right`.

* src/keyboard.c (base_mouse_symbol): New function.
* src/keyboard.h (base_mouse_symbol): Declare.
* src/xterm.c (x_construct_mouse_click): Obey `mouse-wheel-*-event` vars.
(syms_of_xterm): Define the `mouse-wheel-*-event` symbols.

* lisp/completion-preview.el (completion-preview--mouse-map): Don't
bind to `mouse-wheel-*-event`s any more.
* lisp/edmacro.el (edmacro-fix-menu-commands): Remove special casing of
`mouse-wheel-*-event`s.
* lisp/mwheel.el (mouse-wheel-down-event, mouse-wheel-up-event): Remove :set.
(mouse-wheel--setup-bindings): Don't bind to `mouse-wheel-*-event`s any more.
* lisp/progmodes/flymake.el (flymake--mode-line-counter-map): Don't
bind to `mouse-wheel-*-event`s any more if Emacs is recent enough.
---
 lisp/completion-preview.el | 10 +---------
 lisp/edmacro.el            |  8 +-------
 lisp/mwheel.el             | 31 +++++++++++--------------------
 lisp/progmodes/flymake.el  | 19 +++++++++----------
 src/fns.c                  |  1 +
 src/keyboard.c             |  9 +++++++++
 src/keyboard.h             |  2 +-
 src/xterm.c                | 31 +++++++++++++++++++++++++++++--
 8 files changed, 62 insertions(+), 49 deletions(-)

diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
index 6fd60f3c416..6bbf1246a9a 100644
--- a/lisp/completion-preview.el
+++ b/lisp/completion-preview.el
@@ -52,8 +52,6 @@
 
 ;;; Code:
 
-(require 'mwheel)
-
 (defgroup completion-preview nil
   "In-buffer completion preview."
   :group 'completion)
@@ -135,14 +133,8 @@ completion-preview--mouse-map
   "<down-mouse-1>" #'completion-preview-insert
   "C-<down-mouse-1>" #'completion-at-point
   "<down-mouse-2>" #'completion-at-point
-  ;; BEWARE: `mouse-wheel-UP-event' corresponds to `wheel-DOWN' events
-  ;; and vice versa!!
   "<wheel-up>"     #'completion-preview-prev-candidate
-  "<wheel-down>"   #'completion-preview-next-candidate
-  (key-description (vector mouse-wheel-up-event))
-  #'completion-preview-next-candidate
-  (key-description (vector mouse-wheel-down-event))
-  #'completion-preview-prev-candidate)
+  "<wheel-down>"   #'completion-preview-next-candidate)
 
 (defvar-local completion-preview--overlay nil)
 
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
index abfc380d154..a80fe973240 100644
--- a/lisp/edmacro.el
+++ b/lisp/edmacro.el
@@ -725,10 +725,6 @@ edmacro-fix-menu-commands
       (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)
@@ -744,9 +740,7 @@ edmacro-fix-menu-commands
 		;; info is recorded in macros to make this possible.
 		((or (mouse-event-p ev) (mouse-movement-p ev)
 		     (memq (event-basic-type ev)
-			   `( ,mouse-wheel-down-event ,mouse-wheel-up-event
-			      ,mouse-wheel-right-event ,mouse-wheel-left-event
-			      wheel-down wheel-up wheel-left wheel-right)))
+			   '(wheel-down wheel-up wheel-left wheel-right)))
 		 nil)
 		(noerror nil)
 		(t
diff --git a/lisp/mwheel.el b/lisp/mwheel.el
index 66a1fa1a706..82a2c48fd5d 100644
--- a/lisp/mwheel.el
+++ b/lisp/mwheel.el
@@ -65,15 +65,13 @@ mouse-wheel-down-event
   (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-4)
   "Event used for scrolling down, beside `wheel-up', if any."
   :group 'mouse
-  :type 'symbol
-  :set #'mouse-wheel-change-button)
+  :type 'symbol)
 
 (defcustom mouse-wheel-up-event
   (if mouse-wheel-obey-old-style-wheel-buttons 'mouse-5)
   "Event used for scrolling up, beside `wheel-down', if any."
   :group 'mouse
-  :type 'symbol
-  :set #'mouse-wheel-change-button)
+  :type 'symbol)
 
 (defcustom mouse-wheel-click-event 'mouse-2
   "Event that should be temporarily inhibited after mouse scrolling.
@@ -464,25 +462,18 @@ mouse-wheel--setup-bindings
     (cond
      ;; Bindings for changing font size.
      ((and (consp binding) (eq (cdr binding) 'text-scale))
-      (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event
-                           'wheel-down 'wheel-up))
-        (when event
-          (mouse-wheel--add-binding `[,(append (car binding) (list event))]
-                                    'mouse-wheel-text-scale))))
+      (dolist (event '(wheel-down wheel-up))
+        (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
-                           'wheel-down 'wheel-up))
-        (when event
-          (mouse-wheel--add-binding `[,(append (car binding) (list event))]
-                                    'mouse-wheel-global-text-scale))))
+      (dolist (event '(wheel-down wheel-up))
+        (mouse-wheel--add-binding `[,(append (car binding) (list event))]
+                                  'mouse-wheel-global-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
-                           '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))))))))
+      (dolist (event '(wheel-down wheel-up wheel-left wheel-right))
+        (dolist (key (mouse-wheel--create-scroll-keys binding event))
+          (mouse-wheel--add-binding key 'mwheel-scroll)))))))
 
 (when mouse-wheel-mode
   (mouse-wheel--setup-bindings))
diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
index 5974f076556..1411a669891 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -114,10 +114,6 @@
 (require 'thingatpt) ; end-of-thing
 (require 'warnings) ; warning-numeric-level, display-warning
 (require 'compile) ; for some faces
-;; We need the next `require' to avoid compiler warnings and run-time
-;; errors about mouse-wheel-up/down-event in builds --without-x, where
-;; mwheel is not preloaded.
-(require 'mwheel)
 ;; when-let*, if-let*, hash-table-keys, hash-table-values:
 (eval-when-compile (require 'subr-x))
 (require 'project)
@@ -1637,16 +1633,19 @@ flymake--mode-line-counter-scroll-next
 
 (defvar flymake--mode-line-counter-map
   (let ((map (make-sparse-keymap)))
-    ;; BEWARE: `mouse-wheel-UP-event' corresponds to `wheel-DOWN' events
-    ;; and vice versa!!
-    (define-key map (vector 'mode-line mouse-wheel-down-event)
-                #'flymake--mode-line-counter-scroll-prev)
     (define-key map [mode-line wheel-down]
                 #'flymake--mode-line-counter-scroll-next)
-    (define-key map (vector 'mode-line mouse-wheel-up-event)
-                #'flymake--mode-line-counter-scroll-next)
     (define-key map [mode-line wheel-up]
                 #'flymake--mode-line-counter-scroll-prev)
+    (when (< emacs-major-version 30)
+      (require 'mwheel)
+      (defvar mouse-wheel-down-event) (defvar mouse-wheel-up-event)
+      ;; BEWARE: `mouse-wheel-UP-event' corresponds to `wheel-DOWN' events
+      ;; and vice versa!!
+      (define-key map (vector 'mode-line mouse-wheel-down-event)
+                  #'flymake--mode-line-counter-scroll-prev)
+      (define-key map (vector 'mode-line mouse-wheel-up-event)
+                  #'flymake--mode-line-counter-scroll-next))
     map))
 
 (defun flymake--mode-line-counter-1 (type)
diff --git a/src/fns.c b/src/fns.c
index e4fa8157000..48d7b217cb6 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -4855,6 +4855,7 @@ check_mutable_hash_table (Lisp_Object obj, struct Lisp_Hash_Table *h)
    HASH is a previously computed hash code of KEY.
    Value is the index of the entry in H matching KEY.  */
 
+/* FIXME: Callers shouldn't care about the return value!  */
 ptrdiff_t
 hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
 	  hash_hash_t hash)
diff --git a/src/keyboard.c b/src/keyboard.c
index 1f7253a7da1..7c1822b3423 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -7597,6 +7597,15 @@ modify_event_symbol (ptrdiff_t symbol_num, int modifiers, Lisp_Object symbol_kin
   /* Apply modifiers to that symbol.  */
   return apply_modifiers (modifiers, value);
 }
+
+Lisp_Object
+base_mouse_symbol (int button)
+{
+   return modify_event_symbol (button, 0,
+			       Qmouse_click, Vlispy_mouse_stem,
+			       NULL, &mouse_syms, ASIZE (mouse_syms));
+}
+
 
 /* Convert a list that represents an event type,
    such as (ctrl meta backspace), into the usual representation of that
diff --git a/src/keyboard.h b/src/keyboard.h
index 68e68bc2ae3..083b16e4896 100644
--- a/src/keyboard.h
+++ b/src/keyboard.h
@@ -456,7 +456,7 @@ #define EVENT_HEAD_KIND(event_head) \
 extern Lisp_Object read_char (int, Lisp_Object, Lisp_Object,
                               bool *, struct timespec *);
 extern int parse_solitary_modifier (Lisp_Object symbol);
-
+extern Lisp_Object base_mouse_symbol (int button);
 
 /* This is like Vthis_command, except that commands never set it.  */
 extern Lisp_Object real_this_command;
diff --git a/src/xterm.c b/src/xterm.c
index c8a43785564..fcbe7a1ec4f 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -14553,8 +14553,6 @@ x_construct_mouse_click (struct input_event *result,
   int x = event->x;
   int y = event->y;
 
-  /* Make the event type NO_EVENT; we'll change that when we decide
-     otherwise.  */
   result->kind = MOUSE_CLICK_EVENT;
   result->code = event->button - Button1;
   result->timestamp = event->time;
@@ -14564,6 +14562,30 @@ x_construct_mouse_click (struct input_event *result,
 			  ? up_modifier
 			  : down_modifier));
 
+  /* Convert pre-XInput2 wheel events represented as mouse-clicks.  */
+#ifdef HAVE_XINPUT2
+  if (!dpyinfo->supports_xi2)
+#endif
+    {
+      Lisp_Object base = base_mouse_symbol (result->code);
+      int wheel
+       /* BEWARE: `mouse-wheel-UP-event' corresponds to
+          `wheel-DOWN' events and vice versa!!  */
+        = BASE_EQ   (base, find_symbol_value (Qmouse_wheel_up_event))    ? 0
+          : BASE_EQ (base, find_symbol_value (Qmouse_wheel_down_event))  ? 1
+          : BASE_EQ (base, find_symbol_value (Qmouse_wheel_left_event))  ? 2
+          : BASE_EQ (base, find_symbol_value (Qmouse_wheel_right_event)) ? 3
+          : -1;
+      if (wheel >= 0)
+        {
+          result->kind = (event->type != ButtonRelease ? NO_EVENT
+		          : wheel & 2 ? HORIZ_WHEEL_EVENT : WHEEL_EVENT);
+          result->code = 0;         /* Not used.  */
+          result->modifiers &= ~(up_modifier || down_modifier);
+          result->modifiers |= wheel & 1 ? up_modifier : down_modifier;
+        }
+    }
+
   /* If result->window is not the frame's edit widget (which can
      happen with GTK+ scroll bars, for example), translate the
      coordinates so they appear at the correct position.  */
@@ -32444,6 +32466,11 @@ syms_of_xterm (void)
   DEFSYM (Qexpose, "expose");
   DEFSYM (Qdont_save, "dont-save");
 
+  DEFSYM (Qmouse_wheel_down_event, "mouse-wheel-down-event");
+  DEFSYM (Qmouse_wheel_up_event, "mouse-wheel-up-event");
+  DEFSYM (Qmouse_wheel_left_event, "mouse-wheel-left-event");
+  DEFSYM (Qmouse_wheel_right_event, "mouse-wheel-right-event");
+
 #ifdef USE_GTK
   xg_default_icon_file = build_pure_c_string ("icons/hicolor/scalable/apps/emacs.svg");
   staticpro (&xg_default_icon_file);
-- 
2.43.0