Coverage report: /home/ellis/comp/core/lib/io/kbd.lisp

KindCoveredAll%
expression0132 0.0
branch010 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; kbd.lisp --- Keyboard-based IO
2
 
3
 ;; Keyboard-like devices and input
4
 
5
 ;;; Commentary:
6
 
7
 ;; refs:
8
 
9
 ;; - https://www.kernel.org/doc/Documentation/input/event-codes.txt
10
 
11
 ;; - https://github.com/xkbcommon/libxkbcommon/blob/master/tools/interactive-evdev.c
12
 
13
 ;; - https://gitlab.freedesktop.org/libevdev/libevdev/-/tree/master/tools
14
 
15
 ;;; Code:
16
 (in-package :io/kbd)
17
 (pushnew :kbd *features*)
18
 
19
 (defun load-kbd-libs ()
20
   (load-xkbcommon)
21
   (load-evdev))
22
 
23
 ;;; Vars
24
 (defconstant +evdev-offset+ 8)
25
 (defconstant +long-bit+ (sb-alien:alien-size sb-alien:unsigned-long))
26
 
27
 ;;; Conditions
28
 (define-condition kbd-error (error) ())
29
 (deferror simple-kbd-error (simple-error kbd-error) () (:auto t))
30
 
31
 ;;; Objects
32
 (defstruct keyboard 
33
   path 
34
   (sap nil :type (or null (alien (* libevdev)))) ;; device
35
   (state nil)
36
   (compose-state nil)
37
   (keymap nil))
38
 
39
 (defaccessor sap ((self keyboard)) (keyboard-sap self))
40
 
41
 (defun evdev-bit-p (array bit)
42
   "Array elements should be unsigned-long."
43
   (let ((idx (/ bit +long-bit+)))
44
     ;; the literal 1 here is 1LL in C - there is potential to overflow a
45
     ;; singled long.
46
     (logand (aref array idx) (ash 1 (mod bit +long-bit+)))))
47
 
48
 (defun new-device-from-path (path &optional (error t))
49
   ;; opening FD may fail if the user does not have read permissions. When
50
   ;; ERROR is non-nil (the default) this signals an error, else we return nil.
51
   (handler-case
52
       (with-fd (fd path :flags sb-posix:o-rdonly :close nil)
53
         (sb-alien:with-alien ((dev (* evdev::libevdev)))
54
           (let ((ret (evdev:libevdev-new-from-fd fd (sb-alien:addr dev))))
55
             (if (minusp ret)
56
                 (simple-kbd-error (sb-unix::strerror (abs ret)))
57
                 dev))))
58
     (error (c) (when error (error c)))))
59
 
60
 (defun kbd-code-name (code)
61
   (with-alien ((str (* unsigned-char) (make-alien unsigned-char 11)))
62
     (xkb::xkb-keysym-get-name code str 11)
63
     (cast str c-string)))
64
 ;; (kbd-code-name 400) ; "0x00000190"
65
 ;; evdev::+ev-cnt+ evdev::+key-cnt+
66
 (defun keyboard-device-p (path)
67
   "Read some input on device at PATH returning T if it appears to be a keyboard
68
 device."
69
   (with-open-file (st path :element-type 'octet)
70
     (let ((evbits (make-array evdev::+ev-cnt+))
71
           (keybits (make-array evdev::+key-cnt+)))
72
       ;; (sb-posix:ioctl (fd path)
73
       (read-sequence evbits st)
74
       (read-sequence keybits st)
75
       ;; (cons evbits keybits)
76
       (loop for i from evdev::+key-reserved+ upto evdev::+key-min-interesting+
77
             when (evdev-bit-p keybits i)
78
             return t))))
79
       
80
 (defun make-keyboard-from-dev (dev &optional keymap compose-table)
81
   "Return a KEYBOARD given a device, keymap, and compose table. Keyword argument
82
 ERROR when non-nil (the default) causes an error to be signaled if the device
83
 can't be opened, else returns nil."
84
   (make-keyboard :sap dev :keymap keymap))
85
 
86
 (defun get-keyboards (&optional (dir "/dev/input/"))
87
   (let ((devices (directory-files dir))
88
         ret)
89
     (dolist (dev devices ret)
90
       (push (make-keyboard-from-dev (new-device-from-path dev))
91
             ret))))
92
 
93
 ;; (with-open-file (file "/dev/input/event4")
94
 ;;   (let ((fd (sb-sys:fd-stream-fd file))
95
 ;;         (evbits))))
96
 
97
 ;; (xkb::xkb-consumed-mode :xkb)
98
 
99
 (defun print-device-input-info (path &optional (error t))
100
   (when-let ((dev (new-device-from-path path error)))
101
     (when (evdev::libevdev-has-event-code dev evdev::+ev-key+ evdev::+key-scrollup+)
102
       (println "best-guess: mouse"))
103
     (list (evdev::libevdev-get-name dev) 
104
           (evdev::libevdev-get-id-bustype dev) 
105
           (evdev::libevdev-get-id-vendor dev)
106
           (evdev::libevdev-get-id-product dev))))
107
 
108
 (defun device-read-event (dev)
109
   (with-alien ((ev evdev/input:input-event))
110
     (when (evdev::libevdev-has-event-pending dev)
111
       (println "has event pending")
112
       (evdev::libevdev-next-event dev (libevdev-read-flag :normal) (addr ev)))
113
     (with-alien-slots ((* time) type (code evdev/input::code) (value evdev/input::value)) ev
114
       (values 
115
        (cons (sb-posix::alien-timeval-sec time) (sb-posix::alien-timeval-usec time))
116
        type code value))))