Initial Lime window manager

src/x11/input.lisp

@@ -0,0 +1,186 @@
+(in-package #:lime.x11)
+
+;;;; Opt-in keyboard input
+;;;
+;;; This layer translates a passive X11 key grab into a handler supplied by the
+;;; user.  Handlers receive the X11-BACKEND and normally call a command from
+;;; x11/commands.lisp.  It intentionally knows no View ids, Activity names,
+;;; menus, or collision policy itself.
+
+(defstruct keybinding
+  "One character/keysym binding owned by an X11 backend."
+  key
+  modifiers
+  state
+  keycodes
+  handler
+  description)
+
+(defun %input-keysym (display key)
+  (typecase key
+    (character
+     (or (first (xlib:character->keysyms key display))
+         (error 'invalid-transition
+                :description (format nil "No X11 keysym is known for ~S." key))))
+    ((integer 0 *) key)
+    (otherwise
+     (error 'invalid-transition
+            :description "A keybinding key must be a character or X11 keysym integer."))))
+
+(defun %input-keycodes (display key)
+  (let ((keysym (%input-keysym display key)))
+    (or (remove nil (multiple-value-list (xlib:keysym->keycodes display keysym)))
+        (error 'invalid-transition
+               :description (format nil "No X11 keycode is available for ~S." key)))))
+
+(defun %input-state (modifiers)
+  (typecase modifiers
+    (integer modifiers)
+    (list (apply #'xlib:make-state-mask modifiers))
+    (otherwise
+     (error 'invalid-transition
+            :description "Keybinding modifiers must be an integer mask or modifier list."))))
+
+(defparameter +input-ignored-state-mask+
+  ;; X11 commonly assigns Caps Lock to :LOCK and Num Lock to :MOD-2.  Neither
+  ;; should make a window-manager keybinding mysteriously stop matching.  The
+  ;; physical mapping is discovered from the server for more exotic setups in
+  ;; a later input pass; these two portable CLX names cover Lime's current
+  ;; Xorg sessions and the conventional X11 assignment.
+  (xlib:make-state-mask :lock :mod-2))
+
+(defun %input-state-variants (state)
+  "Return STATE's lock-insensitive passive-grab variants.
+
+Passive X11 grabs are exact, whereas a key press with Caps Lock or Num Lock
+active should still invoke the same command.  Register every combination and
+store all of them in the dispatch table; callers continue to expose only the
+user's original modifier list in keybinding descriptions."
+  (remove-duplicates
+   (loop for ignored-state in
+           (list 0
+                 (xlib:make-state-mask :lock)
+                 (xlib:make-state-mask :mod-2)
+                 +input-ignored-state-mask+)
+         collect (logior state ignored-state))))
+
+(defun %input-binding-key (keycode state)
+  (cons keycode state))
+
+(defun %ungrab-binding (backend binding)
+  (let ((root (x11-backend-root backend)))
+    (dolist (keycode (keybinding-keycodes binding))
+      (dolist (state (%input-state-variants (keybinding-state binding)))
+        (xlib:ungrab-key root keycode :modifiers state)))))
+
+(defun %remove-binding (backend binding)
+  "Ungrab BINDING and erase every table entry that still points to it."
+  (%ungrab-binding backend binding)
+  (let ((table (x11-backend-keybindings backend))
+        (keys '()))
+    (maphash (lambda (table-key candidate)
+               (when (eq candidate binding)
+                 (push table-key keys)))
+             table)
+    (dolist (table-key keys)
+      (remhash table-key table))))
+
+(defun bind-key (backend key modifiers handler &key description)
+  "Passively grab KEY with MODIFIERS and run HANDLER when it is pressed.
+
+KEY is a character or an X11 keysym integer.  MODIFIERS is an integer mask or
+a CLX modifier list such as '(:MOD-4).  HANDLER receives BACKEND as its sole
+argument and should invoke a command-layer operation.  Rebinding the same
+physical key/modifier pair replaces its previous handler. The passive grab
+briefly queues subsequent keyboard events until dispatch can hand them to a
+new palette grab or release them normally, even if the trigger was released."
+  (unless (functionp handler)
+    (error 'invalid-transition :description "A keybinding handler must be a function."))
+  (let* ((display (x11-backend-display backend))
+         (root (x11-backend-root backend))
+         (state (%input-state modifiers))
+         (keycodes (%input-keycodes display key))
+         (binding (make-keybinding :key key
+                                   :modifiers modifiers
+                                   :state state
+                                   :keycodes keycodes
+                                   :handler handler
+                                   :description description))
+         (table (x11-backend-keybindings backend)))
+    (dolist (keycode keycodes)
+      (let* ((table-key (%input-binding-key keycode state))
+             (old (gethash table-key table)))
+        (when old
+          (%remove-binding backend old))
+        (dolist (grab-state (%input-state-variants state))
+          (xlib:grab-key root keycode :modifiers grab-state :sync-keyboard-p t)
+          (setf (gethash (%input-binding-key keycode grab-state) table)
+                binding))))
+    (xlib:display-force-output display)
+    binding))
+
+(defun unbind-key (backend key modifiers)
+  "Release KEY/MODIFIERS and return whether at least one binding was removed."
+  (let* ((display (x11-backend-display backend))
+         (state (%input-state modifiers))
+         (keycodes (%input-keycodes display key))
+         (table (x11-backend-keybindings backend))
+         (removed-p nil))
+    (dolist (keycode keycodes)
+      (let* ((table-key (%input-binding-key keycode state))
+             (binding (gethash table-key table)))
+        (when binding
+          (%remove-binding backend binding)
+          (setf removed-p t))))
+    (xlib:display-force-output display)
+    removed-p))
+
+(defun clear-keybindings (backend)
+  "Remove every passive key grab registered through BIND-KEY."
+  (let ((seen (make-hash-table :test #'eq)))
+    (maphash (lambda (table-key binding)
+               (declare (ignore table-key))
+               (unless (gethash binding seen)
+                 (%ungrab-binding backend binding)
+                 (setf (gethash binding seen) t)))
+             (x11-backend-keybindings backend))
+    (clrhash (x11-backend-keybindings backend))
+    (xlib:display-force-output (x11-backend-display backend)))
+  backend)
+
+(defun list-keybindings (backend)
+  "Return unique KEYBINDING objects currently installed on BACKEND."
+  (let ((seen (make-hash-table :test #'eq))
+        (bindings '()))
+    (maphash (lambda (table-key binding)
+               (declare (ignore table-key))
+               (unless (gethash binding seen)
+                 (push binding bindings)
+                 (setf (gethash binding seen) t)))
+             (x11-backend-keybindings backend))
+    (nreverse bindings)))
+
+(defun backend-last-command-error (backend)
+  "Return the most recent condition raised by an input handler, if any."
+  (x11-backend-last-command-error backend))
+
+(defun %handle-key-press (backend keycode state)
+  "Dispatch a grabbed KeyPress without allowing a handler error to kill Lime."
+  (unwind-protect
+       (let ((binding (gethash (%input-binding-key keycode state)
+                              (x11-backend-keybindings backend))))
+         (when binding
+           (handler-case
+               (progn
+                 (setf (x11-backend-last-command-error backend) nil)
+                 (funcall (keybinding-handler binding) backend)
+                 t)
+             (error (condition)
+               (setf (x11-backend-last-command-error backend) condition)
+               nil))))
+    ;; A successful palette grab already thaws input into its own queue.
+    ;; Ordinary commands, failures, and removed bindings must thaw it too.
+    (let ((display (x11-backend-display backend)))
+      (when display
+        (xlib:allow-events display :async-keyboard)
+        (xlib:display-force-output display)))))