lirc.lisp

   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)