(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)
\f
(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)
;; 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)
(:output (sb!unix:fd-isset fd write-fds)))))))
(funcall (handler-function handler)
(handler-descriptor handler)))
- t)
- ((zerop value)
- (when deadlinep
- (signal-deadline))
- nil))))))
+ t))))))
+
projects / sbcl.git / blobdiff