1 #-sbcl (error "No known socket interface for ~a" (lisp-implementation-type))
3 (eval-when (:compile-toplevel :load-toplevel :execute)
4 (require 'sb-bsd-sockets))
5 (defpackage :lirc (:use :cl :sb-bsd-sockets))
9 (defvar *translations* (make-hash-table :test 'equal))
10 (defvar *bindings* '())
12 (defvar *button-repeat* 0)
13 (defvar *button-name* "")
14 (defvar *button-remote* "")
18 (close (prog1 *socket*
19 (setf *socket* nil)))))
21 (defun connect (&key (socket "/dev/lircd"))
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)))
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)))
32 (return (subseq buf 0 (fill-pointer buf)))
33 (vector-push-extend b buf))))))
35 ;(defun bytevec->string (vec)
36 ; (map 'string #'code-char vec))
38 (defun get-keypress-raw ()
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)))))
49 (defun def-translation (symbol key &optional remote)
50 (setf (gethash (if remote
51 (list (string-upcase remote)
54 *translations*) symbol))
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)))))
63 (defun get-keypress ()
64 (multiple-value-bind (key remote repeat)
66 (values (translate remote key) repeat)))
68 (defun get-bindings (key)
70 (stable-sort (let ((ret '()))
71 (dolist (binding *bindings* ret)
72 (multiple-value-bind (sel when prio fun)
75 ((:first) (eq ret '()))
78 (symbol (or (eq sel t)
80 (function (funcall sel key))))
81 (setf ret (append ret `((,fun ,prio))))))))
84 (defmacro defkey (key &body body)
85 `(push (list ,key :first 0 #'(lambda () ,@body))
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)
92 `(list ,key ,when ,prio #'(lambda () ,@body))))
94 `(let ((*bindings* (list* ,@blist *bindings*)))
97 (defmacro with-bound-keys (bindings &body body)
98 `(with-bound-keys* ,bindings :always 0 ,@body))
100 (defmacro keycase (&rest bindings)
101 `(multiple-value-bind (name remote repeat)
103 (let* ((*button* (translate remote name))
105 (*button-remote* remote)
106 (*button-repeat* repeat)
107 (handlers (with-bound-keys* ,bindings :first 0
108 (get-bindings *button*))))
112 (dolist (handler handlers (values-list ret))
114 (let ((ret2 (multiple-value-list (funcall handler))))
119 :report "Ignore this key handler"
122 :report "Ignore this key press and return NIL from KEYCASE"
125 (defmacro keyloop (&rest bindings)
126 (let ((start (gensym "START")))
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))