Add code for determining the type of an input device

* doc/lispref/commands.texi (Command Loop Info):
* etc/NEWS: Update documentation and announce `device-class'.

* lisp/frame.el (x-device-class):
(device-class):
* lisp/term/x-win.el (x-device-class): New functions.

4 files changed, 173 insertions, 3 deletions

diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi
index 74bf0f48692..ace0c025512 100644
--- a/doc/lispref/commands.texi
+++ b/doc/lispref/commands.texi
@@ -1127,6 +1127,23 @@ frame, the value is the frame to which the event was redirected.
 If the last event came from a keyboard macro, the value is @code{macro}.
 @end defvar
 
+@cindex input devices
+@cindex device names
+Input events must come from somewhere; sometimes, that is a keyboard
+macro, a signal, or `unread-command-events', but it is usually a
+physical input device connected to a computer that is controlled by
+the user.  Those devices are referred to as @dfn{input devices}, and
+Emacs associates each input event with the input device from which it
+originated.  They are identified by a name that is unique to each
+input device.
+
+The ability to determine the precise input device used depends on the
+details of each system.  When that information is unavailable, Emacs
+reports keyboard events as originating from the @samp{"Virtual core
+keyboard"}, and other events as originating from the @samp{"Virtual
+core pointer"}.  (These values are used on every platform because the
+X server reports them when detailed device information is not known.)
+
 @defvar last-event-device
 This variable records the name of the input device from which the last
 input event read was generated.  It is @code{nil} if no such device
@@ -1141,6 +1158,65 @@ keyboard"}, depending on whether the event was generated by a pointing
 device (such as a mouse) or a keyboard.
 @end defvar
 
+@defun device-class frame name
+There are various different types of devices, which can be determined
+from their names.  This function can be used to determined the correct
+type of the device @var{name} for an event originating from
+@var{frame}.
+
+The return value is one of the following symbols (``device classes''):
+
+@table @code
+@item core-keyboard
+The core keyboard; this is means the device is a keyboard-like device,
+but no other characteristics are unknown.
+
+@item core-pointer
+The core pointer; this means the device is a pointing device, but no
+other characteristics are known.
+
+@item mouse
+A computer mouse.
+
+@item trackpoint
+A trackpoint or joystick (or other similar control.)
+
+@item eraser
+The other end of a stylus on a graphics tablet, or a standalone
+eraser.
+
+@item pen
+The pointed end of a pen on a graphics tablet, a stylus, or some other
+similar device.
+
+@item puck
+A device that looks like a computer mouse, but reports absolute
+coordinates relative to some other surface.
+
+@item power-button
+A power button or volume button (or other similar control.)
+
+@item keyboard
+A computer keyboard.
+
+@item touchscreen
+A computer touchpad.
+
+@item pad
+A collection of sensitive buttons, rings, and strips commonly found
+around a drawing tablet.
+
+@item touchpad
+An indirect touch device such as a touchpad.
+
+@item piano
+A musical instrument such as an electronic keyboard.
+
+@item test
+A device used by the XTEST extension to report input.
+@end table
+@end defun
+
 @node Adjusting Point
 @section Adjusting Point After Commands
 @cindex adjusting point
diff --git a/etc/NEWS b/etc/NEWS
index 1043873f2d7..2fac893cc52 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1360,9 +1360,10 @@ functions.
 * Lisp Changes in Emacs 29.1
 
 +++
-** New variable 'last-event-device'.
-On X Windows, this specifies the input extension device from which the
-last input event originated.
+** New variable 'last-event-device' and new function 'device-class'.
+On X Windows, 'last-event-device' specifies the input extension device
+from which the last input event originated, and 'device-class' can be
+used to determine the type of an input device.
 
 +++
 ** 'track-mouse' can be a new value 'drag-source'.
diff --git a/lisp/frame.el b/lisp/frame.el
index b681a971aa3..395fe8daad8 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -2433,6 +2433,67 @@ monitors."
                        ,(display-mm-height display)))
            (frames . ,(frames-on-display-list display)))))))))
 
+(declare-function x-device-class (name) "x-win.el")
+
+(defun device-class (frame name)
+  "Return the class of the device NAME for an event generated on FRAME.
+NAME is a string that can be the value of `last-event-device', or
+nil.  FRAME is a window system frame, typically the value of
+`last-event-frame' when `last-event-device' was set.  On some
+window systems, it can also be a display name or a terminal.
+
+The class of a device is one of the following symbols:
+
+  `core-keyboard' means the device is a keyboard-like device, but
+  any other characteristics are unknown.
+
+  `core-pointer' means the device is a pointing device, but any
+  other characteristics are unknown.
+
+  `mouse' means the device is a computer mouse.
+
+  `trackpoint' means the device is a joystick or trackpoint.
+
+  `eraser' means the device is an eraser, which is typically the
+  other end of a stylus on a graphics tablet.
+
+  `pen' means the device is a stylus or some other similar
+  device.
+
+  `puck' means the device is a device similar to a mouse, but
+  reports absolute coordinates.
+
+  `power-button' means the device is a power button, volume
+  button, or some similar control.
+
+  `keyboard' means the device is a keyboard.
+
+  `touchscreen' means the device is a touchscreen.
+
+  `pad' means the device is a collection of buttons and rings and
+  strips commonly found in drawing tablets.
+
+  `touchpad' means the device is an indirect touch device, such
+  as a touchpad.
+
+  `piano' means the device is a piano, or some other kind of
+  musical instrument.
+
+  `test' means the device is used by the XTEST extension to
+  report input.
+
+It can also be nil, which means the class of the device could not
+be determined.  Individual window systems may also return other
+symbols."
+  (let ((frame-type (framep-on-display frame)))
+    (cond ((eq frame-type 'x)
+           (x-device-class name))
+          (t (cond
+              ((string= name "Virtual core pointer")
+               'core-pointer)
+              ((string= name "Virtual core keyboard")
+               'core-keyboard))))))
+
 
 ;;;; Frame geometry values
 
diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el
index a71ae87e215..ac8b1f5df32 100644
--- a/lisp/term/x-win.el
+++ b/lisp/term/x-win.el
@@ -1583,6 +1583,38 @@ frames on all displays."
   (dnd-handle-movement position)
   (redisplay))
 
+(defun x-device-class (name)
+  "Return the device class of NAME.
+Users should not call this function; see `device-class' instead."
+  (let ((downcased-name (downcase name)))
+    (cond
+     ((string-match-p "XTEST" name) 'test)
+     ((string= "Virtual core pointer" name) 'core-pointer)
+     ((string= "Virtual core keyboard" name) 'core-keyboard)
+     ((string-match-p "eraser" downcased-name) 'eraser)
+     ((string-match-p " pad" downcased-name) 'pad)
+     ((or (or (string-match-p "wacom" downcased-name)
+              (string-match-p "pen" downcased-name))
+          (string-match-p "stylus" downcased-name))
+      'pen)
+     ((or (string-prefix-p "xwayland-touch:" name)
+          (string-match-p "touchscreen" downcased-name))
+      'touchscreen)
+     ((or (string-match-p "trackpoint" downcased-name)
+          (string-match-p "stick" downcased-name))
+      'trackpoint)
+     ((or (string-match-p "mouse" downcased-name)
+          (string-match-p "optical" downcased-name)
+          (string-match-p "pointer" downcased-name))
+      'mouse)
+     ((string-match-p "cursor" downcased-name) 'puck)
+     ((string-match-p "keyboard" downcased-name) 'keyboard)
+     ((string-match-p "button" downcased-name) 'power-button)
+     ((string-match-p "touchpad" downcased-name) 'touchpad)
+     ((or (string-match-p "midi" downcased-name)
+          (string-match-p "piano" downcased-name))
+      'piano))))
+
 (setq x-dnd-movement-function #'x-dnd-movement)
 (setq x-dnd-unsupported-drop-function #'x-dnd-handle-unsupported-drop)