-
(defpackage "serve-event"
-
(:use "CL" "FFI" "UFFI"))
-
(in-package "serve-event")
-
-
(clines "#include <sys/select.h>")
-
-
(defstruct (handler
-
(:constructor make-handler (direction descriptor function))
-
(:copier nil))
-
;; Reading or writing...
-
(direction nil :type (member :input :output))
-
;; File descriptor this handler is tied to.
-
;; FIXME: Should be based on FD_SETSIZE
-
(descriptor 0)
-
;; Function to call.
-
(function nil :type function)
-
;; T if this descriptor is bogus.
-
bogus)
-
-
-
(defvar *descriptor-handlers* nil
-
#!+sb-doc
-
"List of all the currently active handlers for file descriptors")
-
-
-
;;; Add a new handler to *descriptor-handlers*.
-
(defun add-fd-handler (fd direction function)
-
"Arrange to call FUNCTION whenever FD is usable. DIRECTION should be
-
either :INPUT or :OUTPUT. The value returned should be passed to
-
SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
-
(unless (member direction '(:input :output))
-
;; FIXME: should be TYPE-ERROR?
-
(error "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction))
-
(let ((handler (make-handler direction fd function)))
-
(push handler *descriptor-handlers*)
-
handler))
-
-
;;; Remove an old handler from *descriptor-handlers*.
-
(defun remove-fd-handler (handler)
-
#!+sb-doc
-
"Removes HANDLER from the list of active handlers."
-
(setf *descriptor-handlers*
-
(delete handler *descriptor-handlers*)))
-
-
;;; Add the handler to *descriptor-handlers* for the duration of BODY.
-
(defmacro with-fd-handler ((fd direction function) &rest body)
-
"Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
-
DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
-
use, and FUNCTION is the function to call whenever FD is usable."
-
(let ((handler (gensym)))
-
`(let (,handler)
-
(unwind-protect
-
(progn
-
(setf ,handler (add-fd-handler ,fd ,direction ,function))
-
,@body)
-
(when ,handler
-
(remove-fd-handler ,handler))))))
-
-
-
(defmacro fd-zero(fdset)
-
`(c-inline (,fdset) (:object) :void
-
"FD_ZERO((fd_set*)#0->foreign.data)"
-
:one-liner t
-
:side-effects t))
-
-
(defmacro fd-set (fd fdset)
-
`(c-inline (,fd ,fdset) (:int :object) :void
-
"FD_SET(#0, (fd_set*)#1->foreign.data);"
-
:one-liner t
-
:side-effects t))
-
-
(defmacro fd-isset (fd fdset)
-
`(c-inline (,fd ,fdset) (:int :object) :int
-
"FD_ISSET(#0, (fd_set*)#1->foreign.data)"
-
:one-liner t
-
:side-effects t))
-
-
(defun fdset-size ()
-
(c-inline () () :int "sizeof(fd_set)" :one-liner t :side-effects nil))
-
-
-
(defun serve-event (&optional (seconds 0))
-
"Receive pending events on all FD-STREAMS and dispatch to the appropriate
-
handler functions. If timeout is specified, server will wait the specified
-
time (in seconds) and then return, otherwise it will wait until something
-
happens. Server returns T if something happened and NIL otherwise. Timeout
-
0 means polling without waiting."
-
-
;; fd_set is an opaque typedef, so we can't declare it locally.
-
;; However we can fine out its size and allocate a char array of
-
;; the same size which can be used in its place.
-
(let ((fsize (fdset-size)))
-
(with-foreign-objects ((rfd `(:array :unsigned-char ,fsize))
-
(wfd `(:array :unsigned-char ,fsize)))
-
(fd-zero rfd)
-
(fd-zero wfd)
-
-
(let ((maxfd 0))
-
;; Load the descriptors into the relevant set
-
(dolist (handler *descriptor-handlers*)
-
(let ((fd (handler-descriptor handler)))
-
(ecase (handler-direction handler)
-
(:input (fd-set fd rfd))
-
(:output (fd-set fd wfd)))
-
(when (> fd maxfd)
-
(setf maxfd fd))))
-
-
(let ((retval
-
(c-inline (rfd wfd (1+ maxfd) seconds)
-
(:object :object :int :int) :int
-
"{ struct timeval tv;
-
tv.tv_sec = #3;
-
tv.tv_usec = 0;
-
@(return) = select(#2, #0->foreign.data,
-
#1->foreign.data,
-
NULL, &tv); }"
-
:one-liner nil
-
:side-effects t)))
-
(cond ((zerop retval) nil)
-
((minusp retval)
-
(error "Error during select"))
-
(t
-
(dolist (handler *descriptor-handlers*)
-
(let ((fd (handler-descriptor handler)))
-
(if (plusp (ecase (handler-direction handler)
-
(:input (fd-isset fd rfd))
-
(:output (fd-isset fd wfd))))
-
(funcall (handler-function handler)
-
(handler-descriptor handler))))))))))))
-
-
-
;;; Wait for up to timeout seconds for an event to happen. Make sure all
-
;;; pending events are processed before returning.
-
(defun serve-all-events (&optional (timeout 0))
-
"SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
-
SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with a
-
timeout of 0 until there are no more events to serve. SERVE-ALL-EVENTS returns
-
T if SERVE-EVENT did something and NIL if not."
-
(do ((res nil)
-
(sval (serve-event timeout) (serve-event 0)))
-
((null sval) res)
-
(setq res t)))
-
-
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
;; Test Example
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
;; (defun test-stdin ()
-
;; (format t "DOING STDIN~%")
-
;; (with-fd-handler (0 :input #'(lambda (fd) (declare (ignore fd))
-
;; (format t "Got data~%")
-
;; (read-char)))
-
;; (loop ;; FIXME: End condition
-
;; (format t "Entering serve-all-events...~%")(force-output)
-
;; (serve-all-events 5)
-
;; (format t "Events served~%"))))
