X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fserve-event.lisp;h=b1b8aaf39382594f57e41a8455e2833b52c8cab3;hb=068cf4b55af3f8f8acf2c7c06869441612261cd4;hp=af166658ebad8fdf80c20d725ba65ea3483da3fc;hpb=3ac386bf6520a67343aadce1b3e61f580406b740;p=sbcl.git

diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp
index af16665..b1b8aaf 100644
--- a/src/code/serve-event.lisp
+++ b/src/code/serve-event.lisp
@@ -200,31 +200,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)
@@ -258,8 +291,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))))))
+