1.0.11.1: Handle set-but-empty environment variables
[sbcl.git] / src / code / serve-event.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
9
10 (in-package "SB!IMPL")
11
12 ;;;; file descriptor I/O noise
13
14 (defstruct (handler
15             (:constructor make-handler (direction descriptor function))
16             (:copier nil))
17   ;; Reading or writing...
18   (direction nil :type (member :input :output))
19   ;; File descriptor this handler is tied to.
20   (descriptor 0 :type (mod #.sb!unix:fd-setsize))
21   ;; T iff this handler is running.
22   ;;
23   ;; FIXME: unused. At some point this used to be set to T
24   ;; around the call to the handler-function, but that was commented
25   ;; out with the verbose explantion "Doesn't work -- ACK".
26   active
27   ;; Function to call.
28   (function nil :type function)
29   ;; T if this descriptor is bogus.
30   bogus)
31
32 (def!method print-object ((handler handler) stream)
33   (print-unreadable-object (handler stream :type t)
34     (format stream
35             "~A on ~:[~;BOGUS ~]descriptor ~W: ~S"
36             (handler-direction handler)
37             (handler-bogus handler)
38             (handler-descriptor handler)
39             (handler-function handler))))
40
41 (defvar *descriptor-handlers* nil
42   #!+sb-doc
43   "List of all the currently active handlers for file descriptors")
44
45 (sb!xc:defmacro with-descriptor-handlers (&body forms)
46   ;; FD-STREAM functionality can add and remove descriptors on it's
47   ;; own, so getting an interrupt while modifying this and the
48   ;; starting to recursively modify it could lose...
49   `(without-interrupts ,@forms))
50
51 (defun list-all-descriptor-handlers ()
52   (with-descriptor-handlers
53     (copy-list *descriptor-handlers*)))
54
55 (defun select-descriptor-handlers (function)
56   (declare (function function))
57   (with-descriptor-handlers
58     (remove-if-not function *descriptor-handlers*)))
59
60 (defun map-descriptor-handlers (function)
61   (declare (function function))
62   (with-descriptor-handlers
63     (dolist (handler *descriptor-handlers*)
64       (funcall function handler))))
65
66 ;;; Add a new handler to *descriptor-handlers*.
67 (defun add-fd-handler (fd direction function)
68   #!+sb-doc
69   "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
70   either :INPUT or :OUTPUT. The value returned should be passed to
71   SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
72   (unless (member direction '(:input :output))
73     ;; FIXME: should be TYPE-ERROR?
74     (error "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction))
75   (let ((handler (make-handler direction fd function)))
76     (with-descriptor-handlers
77       (push handler *descriptor-handlers*))
78     handler))
79
80 ;;; Remove an old handler from *descriptor-handlers*.
81 (defun remove-fd-handler (handler)
82   #!+sb-doc
83   "Removes HANDLER from the list of active handlers."
84   (with-descriptor-handlers
85     (setf *descriptor-handlers*
86           (delete handler *descriptor-handlers*))))
87
88 ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
89 (defun invalidate-descriptor (fd)
90   #!+sb-doc
91   "Remove any handers refering to fd. This should only be used when attempting
92   to recover from a detected inconsistancy."
93   (with-descriptor-handlers
94     (setf *descriptor-handlers*
95           (delete fd *descriptor-handlers*
96                   :key #'handler-descriptor))))
97
98 ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
99 (defmacro with-fd-handler ((fd direction function) &rest body)
100   #!+sb-doc
101   "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
102    DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
103    use, and FUNCTION is the function to call whenever FD is usable."
104   (let ((handler (gensym)))
105     `(let (,handler)
106        (unwind-protect
107            (progn
108              (setf ,handler (add-fd-handler ,fd ,direction ,function))
109              ,@body)
110          (when ,handler
111            (remove-fd-handler ,handler))))))
112
113 ;;; First, get a list and mark bad file descriptors. Then signal an error
114 ;;; offering a few restarts.
115 (defun handler-descriptors-error ()
116   (let ((bogus-handlers nil))
117     (dolist (handler (list-all-descriptor-handlers))
118       (unless (or (handler-bogus handler)
119                   (sb!unix:unix-fstat (handler-descriptor handler)))
120         (setf (handler-bogus handler) t)
121         (push handler bogus-handlers)))
122     (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
123                          bogus-handlers (length bogus-handlers))
124       (remove-them ()
125         :report "Remove bogus handlers."
126         (with-descriptor-handlers
127           (setf *descriptor-handlers*
128                 (delete-if #'handler-bogus *descriptor-handlers*))))
129       (retry-them ()
130         :report "Retry bogus handlers."
131        (dolist (handler bogus-handlers)
132          (setf (handler-bogus handler) nil)))
133       (continue ()
134         :report "Go on, leaving handlers marked as bogus.")))
135   nil)
136
137 \f
138 ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends
139
140 ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
141 ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
142 ;;; timeout at the correct time irrespective of how many events are handled in
143 ;;; the meantime.
144 (defun wait-until-fd-usable (fd direction &optional timeout)
145   #!+sb-doc
146   "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
147 :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
148 up."
149   (prog (usable)
150    :restart
151      (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp)
152          (decode-timeout timeout)
153        (declare (type (or integer null) to-sec to-usec))
154        (with-fd-handler (fd direction (lambda (fd)
155                                         (declare (ignore fd))
156                                         (setf usable t)))
157          (loop
158            (sub-serve-event to-sec to-usec signalp)
159            (when usable
160              (return-from wait-until-fd-usable t))
161            (when to-sec
162              (multiple-value-bind (sec usec)
163                  (decode-internal-time (get-internal-real-time))
164                (setf to-sec (- stop-sec sec))
165                (cond ((> usec stop-usec)
166                       (decf to-sec)
167                       (setf to-usec (- (+ stop-usec 1000000) usec)))
168                      (t
169                       (setf to-usec (- stop-usec usec)))))
170              (when (or (minusp to-sec) (minusp to-usec))
171                (if signalp
172                    (progn
173                      (signal-deadline)
174                      (go :restart))
175                    (return-from wait-until-fd-usable nil)))))))))
176 \f
177 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
178 ;;; pending events are processed before returning.
179 (defun serve-all-events (&optional timeout)
180   #!+sb-doc
181   "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
182 SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with a
183 timeout of 0 until there are no more events to serve. SERVE-ALL-EVENTS returns
184 T if SERVE-EVENT did something and NIL if not."
185   (do ((res nil)
186        (sval (serve-event timeout) (serve-event 0)))
187       ((null sval) res)
188     (setq res t)))
189
190 ;;; Serve a single set of events.
191 (defun serve-event (&optional timeout)
192   #!+sb-doc
193   "Receive pending events on all FD-STREAMS and dispatch to the appropriate
194 handler functions. If timeout is specified, server will wait the specified
195 time (in seconds) and then return, otherwise it will wait until something
196 happens. Server returns T if something happened and NIL otherwise. Timeout
197 0 means polling without waiting."
198   (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp)
199       (decode-timeout timeout)
200     (declare (ignore stop-sec stop-usec))
201     (sub-serve-event to-sec to-usec signalp)))
202
203 ;;; Takes timeout broken into seconds and microseconds.
204 (defun sub-serve-event (to-sec to-usec deadlinep)
205   ;; Next, wait for something to happen.
206   (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))
207                         (write-fds (sb!alien:struct sb!unix:fd-set)))
208
209       (sb!unix:fd-zero read-fds)
210       (sb!unix:fd-zero write-fds)
211       (let ((count 0))
212         (declare (type index count))
213
214         ;; Initialize the fd-sets for UNIX-SELECT and return the active
215         ;; descriptor count.
216         (map-descriptor-handlers
217          (lambda (handler)
218            ;; FIXME: If HANDLER-ACTIVE ever is reinstanted, it needs
219            ;; to be checked here in addition to HANDLER-BOGUS
220            (unless (handler-bogus handler)
221              (let ((fd (handler-descriptor handler)))
222                (ecase (handler-direction handler)
223                  (:input (sb!unix:fd-set fd read-fds))
224                  (:output (sb!unix:fd-set fd write-fds)))
225                (when (> fd count)
226                  (setf count fd))))))
227         (incf count)
228
229       ;; Next, wait for something to happen.
230       (multiple-value-bind (value err)
231           (sb!unix:unix-fast-select count
232                                     (sb!alien:addr read-fds)
233                                     (sb!alien:addr write-fds)
234                                     nil to-sec to-usec)
235         #!+win32
236         (declare (ignore err))
237         ;; Now see what it was (if anything)
238         (cond ((not value)
239                ;; Interrupted or one of the file descriptors is bad.
240                ;; FIXME: Check for other errnos. Why do we return true
241                ;; when interrupted?
242                #!-win32
243                (if (eql err sb!unix:eintr)
244                    t
245                  (handler-descriptors-error))
246                #!+win32
247                (handler-descriptors-error))
248               ((plusp value)
249                ;; Got something. Call file descriptor handlers
250                ;; according to the readable and writable masks
251                ;; returned by select.
252                (dolist (handler
253                         (select-descriptor-handlers
254                          (lambda (handler)
255                            (let ((fd (handler-descriptor handler)))
256                              (ecase (handler-direction handler)
257                                (:input (sb!unix:fd-isset fd read-fds))
258                                (:output (sb!unix:fd-isset fd write-fds)))))))
259                  (funcall (handler-function handler)
260                           (handler-descriptor handler)))
261                t)
262               ((zerop value)
263                (when deadlinep
264                  (signal-deadline))
265                nil))))))