diff --git a/contrib/serve-event/event-test.lisp b/contrib/serve-event/event-test.lisp new file mode 100644 index 000000000..baa72584f --- /dev/null +++ b/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~%")))) diff --git a/contrib/serve-event/serve-event.lisp b/contrib/serve-event/serve-event.lisp new file mode 100644 index 000000000..65b24b65d --- /dev/null +++ b/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 ") + +(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~%")))) diff --git a/src/CHANGELOG b/src/CHANGELOG index 07d0a298f..e01ad7475 100644 --- a/src/CHANGELOG +++ b/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). diff --git a/src/compile.lsp.in b/src/compile.lsp.in index 8a9c628d9..883401b73 100644 --- a/src/compile.lsp.in +++ b/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 ;;; diff --git a/src/configure b/src/configure index 097befc34..ce8aaa44c 100755 --- a/src/configure +++ b/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 diff --git a/src/configure.in b/src/configure.in index eee6c4b8a..0cf55f4f4 100644 --- a/src/configure.in +++ b/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