Added strict ASCII codec.
[lisp-utils.git] / lirc.lisp
... / ...
CommitLineData
1#-sbcl (error "No known socket interface for ~a" (lisp-implementation-type))
2
3(eval-when (:compile-toplevel :load-toplevel :execute)
4 (require 'sb-bsd-sockets))
5(defpackage :lirc (:use :cl :sb-bsd-sockets))
6(in-package :lirc)
7
8(defvar *socket* nil)
9(defvar *translations* (make-hash-table :test 'equal))
10(defvar *bindings* '())
11(defvar *button* nil)
12(defvar *button-repeat* 0)
13(defvar *button-name* "")
14(defvar *button-remote* "")
15
16(defun disconnect ()
17 (if *socket*
18 (close (prog1 *socket*
19 (setf *socket* nil)))))
20
21(defun connect (&key (socket "/dev/lircd"))
22 (disconnect)
23 (setf *socket* (let ((sk (make-instance 'local-socket :type :stream)))
24 (socket-connect sk socket)
25 (socket-make-stream sk :input t :output t)))
26 (values))
27
28(defun read-delim (in delim)
29 (let ((buf (make-array '(16) :element-type 'character :adjustable t :fill-pointer 0)))
30 (loop (let ((b (read-char in nil delim)))
31 (if (eq b delim)
32 (return (subseq buf 0 (fill-pointer buf)))
33 (vector-push-extend b buf))))))
34
35;(defun bytevec->string (vec)
36; (map 'string #'code-char vec))
37
38(defun get-keypress-raw ()
39 (if (null *socket*)
40 (error "Not connected to lircd"))
41 (with-input-from-string (lin (read-delim *socket* #\newline))
42 (let* ((code (read-delim lin #\space))
43 (repeat (read-delim lin #\space))
44 (name (read-delim lin #\space))
45 (remote (read-delim lin #\space)))
46 (declare (type string code repeat name remote))
47 (values name remote (parse-integer repeat :radix 16) (parse-integer code :radix 16)))))
48
49(defun def-translation (symbol key &optional remote)
50 (setf (gethash (if remote
51 (list (string-upcase remote)
52 (string-upcase key))
53 (string-upcase key))
54 *translations*) symbol))
55
56(defun translate (remote key)
57 (setf remote (string-upcase remote)
58 key (string-upcase key))
59 (cond ((gethash (list remote key) *translations*))
60 ((gethash key *translations*))
61 ((intern key (find-package 'keyword)))))
62
63(defun get-keypress ()
64 (multiple-value-bind (key remote repeat)
65 (get-keypress-raw)
66 (values (translate remote key) repeat)))
67
68(defun get-bindings (key)
69 (mapcar #'first
70 (stable-sort (let ((ret '()))
71 (dolist (binding *bindings* ret)
72 (multiple-value-bind (sel when prio fun)
73 (values-list binding)
74 (if (and (ecase when
75 ((:first) (eq ret '()))
76 ((:always) t))
77 (etypecase sel
78 (symbol (or (eq sel t)
79 (eq sel key)))
80 (function (funcall sel key))))
81 (setf ret (append ret `((,fun ,prio))))))))
82 #'> :key #'second)))
83
84(defmacro defkey (key &body body)
85 `(push (list ,key :first 0 #'(lambda () ,@body))
86 *bindings*))
87
88(defmacro with-bound-keys* (bindings defwhen defprio &body body)
89 (let ((blist (mapcar #'(lambda (binding)
90 (destructuring-bind ((key &key (prio defprio) (when defwhen)) &body body)
91 binding
92 `(list ,key ,when ,prio #'(lambda () ,@body))))
93 bindings)))
94 `(let ((*bindings* (list* ,@blist *bindings*)))
95 ,@body)))
96
97(defmacro with-bound-keys (bindings &body body)
98 `(with-bound-keys* ,bindings :always 0 ,@body))
99
100(defmacro keycase (&rest bindings)
101 `(multiple-value-bind (name remote repeat)
102 (get-keypress-raw)
103 (let* ((*button* (translate remote name))
104 (*button-name* name)
105 (*button-remote* remote)
106 (*button-repeat* repeat)
107 (handlers (with-bound-keys* ,bindings :first 0
108 (get-bindings *button*))))
109 (restart-case
110 (let ((first t)
111 (ret '()))
112 (dolist (handler handlers (values-list ret))
113 (restart-case
114 (let ((ret2 (multiple-value-list (funcall handler))))
115 (if first
116 (setf first nil
117 ret ret2)))
118 (ignore-handler ()
119 :report "Ignore this key handler"
120 nil))))
121 (ignore-key ()
122 :report "Ignore this key press and return NIL from KEYCASE"
123 nil)))))
124
125(defmacro keyloop (&rest bindings)
126 (let ((start (gensym "START")))
127 `(block nil
128 (tagbody
129 ,start
130 (keycase ,@bindings)
131 (go ,start)))))
132
133(export '(connect disconnect
134 def-translation get-keypress
135 *button* *button-repeat* *button-name* *button-remote*
136 defkey with-bound-keys keycase keyloop ignore-key ignore-handler))
137(provide :lirc)