X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fserve-event.lisp;h=2046161d50e586c83450b675759062e2e446511b;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=af166658ebad8fdf80c20d725ba65ea3483da3fc;hpb=3ac386bf6520a67343aadce1b3e61f580406b740;p=sbcl.git diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp index af16665..2046161 100644 --- a/src/code/serve-event.lisp +++ b/src/code/serve-event.lisp @@ -119,19 +119,20 @@ (sb!unix:unix-fstat (handler-descriptor handler))) (setf (handler-bogus handler) t) (push handler bogus-handlers))) - (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P." - bogus-handlers (length bogus-handlers)) - (remove-them () - :report "Remove bogus handlers." - (with-descriptor-handlers - (setf *descriptor-handlers* - (delete-if #'handler-bogus *descriptor-handlers*)))) - (retry-them () - :report "Retry bogus handlers." - (dolist (handler bogus-handlers) - (setf (handler-bogus handler) nil))) - (continue () - :report "Go on, leaving handlers marked as bogus."))) + (when bogus-handlers + (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P." + bogus-handlers (length bogus-handlers)) + (remove-them () + :report "Remove bogus handlers." + (with-descriptor-handlers + (setf *descriptor-handlers* + (delete-if #'handler-bogus *descriptor-handlers*)))) + (retry-them () + :report "Retry bogus handlers." + (dolist (handler bogus-handlers) + (setf (handler-bogus handler) nil))) + (continue () + :report "Go on, leaving handlers marked as bogus.")))) nil) @@ -200,31 +201,64 @@ happens. Server returns T if something happened and NIL otherwise. Timeout (declare (ignore stop-sec stop-usec)) (sub-serve-event to-sec to-usec signalp))) -;;; Takes timeout broken into seconds and microseconds. +;;; When a *periodic-polling-function* is defined the server will not +;;; block for more than the maximum event timeout and will call the +;;; polling function if it does time out. +(declaim (type (or null symbol function) *periodic-polling-function*)) +(defvar *periodic-polling-function* nil + "Either NIL, or a designator for a function callable without any +arguments. Called when the system has been waiting for input for +longer then *PERIODIC-POLLING-PERIOD* seconds. Shared between all +threads, unless locally bound. EXPERIMENTAL.") +(declaim (real *periodic-polling-period*)) +(defvar *periodic-polling-period* 0 + "A real number designating the number of seconds to wait for input +at maximum, before calling the *PERIODIC-POLLING-FUNCTION* \(if any.) +Shared between all threads, unless locally bound. EXPERIMENTAL.") + +;;; Takes timeout broken into seconds and microseconds, NIL timeout means +;;; to wait as long as needed. (defun sub-serve-event (to-sec to-usec deadlinep) - ;; Next, wait for something to happen. + (or + (if *periodic-polling-function* + (multiple-value-bind (p-sec p-usec) + (decode-internal-time + (seconds-to-internal-time *periodic-polling-period*)) + (if to-sec + (loop repeat (/ (+ to-sec (/ to-usec 1e6)) + *periodic-polling-period*) + thereis (sub-sub-serve-event p-sec p-usec) + do (funcall *periodic-polling-function*)) + (loop thereis (sub-sub-serve-event p-sec p-usec) + do (funcall *periodic-polling-function*)))) + (sub-sub-serve-event to-sec to-usec)) + (when deadlinep + (signal-deadline)))) + +;;; Handles the work of the above, except for periodic polling. Returns +;;; true if something of interest happened. +(defun sub-sub-serve-event (to-sec to-usec) (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)) (write-fds (sb!alien:struct sb!unix:fd-set))) + (sb!unix:fd-zero read-fds) + (sb!unix:fd-zero write-fds) + (let ((count 0)) + (declare (type index count)) - (sb!unix:fd-zero read-fds) - (sb!unix:fd-zero write-fds) - (let ((count 0)) - (declare (type index count)) - - ;; Initialize the fd-sets for UNIX-SELECT and return the active - ;; descriptor count. - (map-descriptor-handlers - (lambda (handler) - ;; FIXME: If HANDLER-ACTIVE ever is reinstanted, it needs - ;; to be checked here in addition to HANDLER-BOGUS - (unless (handler-bogus handler) - (let ((fd (handler-descriptor handler))) - (ecase (handler-direction handler) - (:input (sb!unix:fd-set fd read-fds)) - (:output (sb!unix:fd-set fd write-fds))) - (when (> fd count) - (setf count fd)))))) - (incf count) + ;; Initialize the fd-sets for UNIX-SELECT and return the active + ;; descriptor count. + (map-descriptor-handlers + (lambda (handler) + ;; FIXME: If HANDLER-ACTIVE ever is reinstanted, it needs + ;; to be checked here in addition to HANDLER-BOGUS + (unless (handler-bogus handler) + (let ((fd (handler-descriptor handler))) + (ecase (handler-direction handler) + (:input (sb!unix:fd-set fd read-fds)) + (:output (sb!unix:fd-set fd write-fds))) + (when (> fd count) + (setf count fd)))))) + (incf count) ;; Next, wait for something to happen. (multiple-value-bind (value err) @@ -240,9 +274,15 @@ happens. Server returns T if something happened and NIL otherwise. Timeout ;; FIXME: Check for other errnos. Why do we return true ;; when interrupted? #!-win32 - (if (eql err sb!unix:eintr) - t - (handler-descriptors-error)) + (case err + (#.sb!unix:ebadf + (handler-descriptors-error)) + ((#.sb!unix:eintr #.sb!unix:eagain) + t) + (otherwise + (with-simple-restart (continue "Ignore failure and continue.") + (simple-perror "Unix system call select() failed" + :errno err)))) #!+win32 (handler-descriptors-error)) ((plusp value) @@ -258,8 +298,5 @@ happens. Server returns T if something happened and NIL otherwise. Timeout (:output (sb!unix:fd-isset fd write-fds))))))) (funcall (handler-function handler) (handler-descriptor handler))) - t) - ((zerop value) - (when deadlinep - (signal-deadline)) - nil)))))) + t)))))) +