SERVE-EVENT contributed by Steve Smith

contrib/serve-event/event-test.lisp

@@ -0,0 +1,20 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Test Example
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defpackage "event-test"
+  (:use "CL" "sockets"))
+(in-package "event-test")
+
+
+(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~%"))))

contrib/serve-event/serve-event.lisp

@@ -0,0 +1,191 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; This file provides a port the SBCL/CMUCL 'serve-event'
+;; functionality to ecl.  serve-event provides a lispy abstraction of
+;; unix select(2) non-blocking IO (and potentially other variants such as
+;; epoll).  It works with Unix-level file-descriptors, which can be
+;; retrieved from the sockets module using the socket-file-descriptor
+;; slot.
+;;
+;; As this file is based on SBCL's serve-event module it is being
+;; released under the same (non) license as SBCL (i.e. public-domain).
+;;
+;; The original port was made by Steve Smith (tarkasteve@gmail.com)
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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~%"))))
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defpackage "SERVE-EVENT"
+  (:use "CL" "FFI" "UFFI")
+  (:export "WITH-FD-HANDER" "ADD-FD-HANDLER" "REMOVE-FD-HANDLER"
+           "SERVE-EVENT" "SERVE-ALL-EVENTS"))
+
+(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)))
+
+(provide 'serve-event)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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~%"))))

src/CHANGELOG

@@ -10,6 +10,8 @@ ECL 1.0:
 
 * New features:
 
+ - SBCL's SERVE-EVENT package has been ported to ECL by Steve Smith.
+
  - New commands, :RESTART, :R1, :R2, etc, allow invoking restarts (contributed
    by Chui Tey).
 

src/compile.lsp.in

@@ -159,6 +159,12 @@
 	      :dir "build:ext;"
 	      :prefix "EXT")
 
+#+WANTS-SERVE-EVENT
+(build-module "serve-event"
+	      '("ext:serve-event;serve-event.lisp")
+	      :dir "build:ext;"
+	      :prefix "EXT")
+
 ;;;
 ;;; * Test suite
 ;;;

src/configure

@@ -1,5 +1,5 @@
 #! /bin/sh
-# From configure.in Revision: 1.144 .
+# From configure.in Revision.
 # Guess values for system-dependent variables and create Makefiles.
 # Generated by GNU Autoconf 2.60 for ecl 0.9i.
 #
@@ -1341,6 +1341,7 @@ Optional Packages:
                           NPTL-aware glibc and maybe Windows)
   --with-cxx              build ECL using C++ compiler (default=NO)
   --with-tcp              include socket interface (default=YES)
+  --with-serve-event      include serve-event module (default=YES)
   --with-clx              include CLX library (default=NO)
   --with-clos-streams     user defined stream objects (default=YES)
   --with-cmuformat        use CMUCL's FORMAT routine (default=YES)
@@ -1979,6 +1980,15 @@ fi
 
 
 
+# Check whether --with-serve_event was given.
+if test "${with_serve_event+set}" = set; then
+  withval=$with_serve_event;
+else
+  with_serve_event=yes
+fi
+
+
+
 # Check whether --with-clx was given.
 if test "${with_clx+set}" = set; then
   withval=$with_clx;
@@ -11851,6 +11861,14 @@ LSP_FEATURES="(cons :wants-sockets ${LSP_FEATURES})"
   LIBS="${LIBS} ${TCPLIBS}"
 fi
 
+if test "${with_serve_event}" = "yes"; then
+
+
+LSP_FEATURES="(cons :wants-serve-event ${LSP_FEATURES})"
+
+
+fi
+
 if test "${with_asdf}" = "yes"; then
 
 

src/configure.in

@@ -122,6 +122,11 @@ AC_ARG_WITH(tcp,
                   [include socket interface (default=YES)]),
   [], [with_tcp=yes])
 
+AC_ARG_WITH(serve_event,
+  AS_HELP_STRING( [--with-serve-event],
+                  [include serve-event module (default=YES)]),
+  [], [with_serve_event=yes])
+
 AC_ARG_WITH(clx,
   AS_HELP_STRING( [--with-clx],
                   [include CLX library (default=NO)]),
@@ -508,6 +513,10 @@ if test "${with_tcp}" = "yes"; then
   LIBS="${LIBS} ${TCPLIBS}"
 fi
 
+if test "${with_serve_event}" = "yes"; then
+  ECL_ADD_LISP_MODULE([serve-event])
+fi
+
 if test "${with_asdf}" = "yes"; then
   ECL_ADD_LISP_MODULE([asdf])
 fi