/[cmucl]/src/code/serve-event.lisp
ViewVC logotype

Contents of /src/code/serve-event.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19.1.1 - (show annotations) (vendor branch)
Tue Feb 23 16:29:46 1993 UTC (21 years, 2 months ago) by ram
Branch: new_struct
Changes since 1.19: +81 -88 lines
changed to use unix-fast-select.
1 ;;; -*- Log: code.log; Package: LISP -*-
2
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/serve-event.lisp,v 1.19.1.1 1993/02/23 16:29:46 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; SYSTEM:SERVE-EVENT, now in it's own file.
15 ;;;
16 ;;; Re-written by William Lott, July 1989 - January 1990.
17 ;;;
18 ;;; **********************************************************************
19
20 (in-package "SYSTEM")
21
22 (export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor
23 serve-event serve-all-events wait-until-fd-usable
24 make-object-set object-set-operation *xwindow-table*
25 map-xwindow add-xwindow-object remove-xwindow-object))
26
27 (in-package "EXTENSIONS")
28
29 (export '(*display-event-handlers*))
30
31 (in-package "LISP")
32
33
34
35 ;;;; Object set stuff.
36
37 ;;;
38 ;;; Hashtable from ports to objects. Each entry is a cons (object . set).
39 ;;;
40 ;(defvar *port-table* (make-hash-table :test #'eql))
41
42 ;;; Hashtable from windows to objects. Each entry is a cons (object . set).
43 ;;;
44 (defvar *xwindow-table* (make-hash-table :test #'eql))
45
46
47 (defstruct (object-set
48 (:constructor make-object-set
49 (name &optional
50 (default-handler #'default-default-handler)))
51 (:print-function
52 (lambda (s stream d)
53 (declare (ignore d))
54 (format stream "#<Object Set ~S>" (object-set-name s)))))
55 name ; Name, for descriptive purposes.
56 (table (make-hash-table :test #'eq)) ; Message-ID or xevent-type --> handler fun.
57 default-handler)
58
59 (setf (documentation 'make-object-set 'function)
60 "Make an object set for use by a RPC/xevent server. Name is for
61 descriptive purposes only.")
62
63 ;;; Default-Default-Handler -- Internal
64 ;;;
65 ;;; If no such operation defined, signal an error.
66 ;;;
67 (defun default-default-handler (object)
68 (error "You lose, object: ~S" object))
69
70
71 ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
72 ;;; object set mapped to by a xwindow or port in *xwindow-table* or
73 ;;; *port-table*.
74 ;;;
75 (macrolet ((defmapper (name table)
76 `(defun ,(intern (concatenate 'simple-string
77 "MAP-" (symbol-name name)))
78 (,name)
79 ,(format nil "Return as multiple values the object and ~
80 object-set mapped to by ~A."
81 (string-downcase (symbol-name name)))
82 (let ((temp (gethash ,name ,table)))
83 (if temp
84 (values (car temp) (cdr temp))
85 (values nil nil))))))
86 ;(defmapper port *port-table*)
87 (defmapper xwindow *xwindow-table*))
88
89
90 ;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair
91 ;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.
92 ;;;
93 (macrolet ((def-add-object (name table)
94 `(defun ,(intern (concatenate 'simple-string
95 "ADD-" (symbol-name name)
96 "-OBJECT"))
97 (,name object object-set)
98 ,(format nil "Add a new ~A/object/object-set association."
99 (string-downcase (symbol-name name)))
100 (check-type object-set object-set)
101 (setf (gethash ,name ,table) (cons object object-set))
102 object)))
103 ;(def-add-object port *port-table*)
104 (def-add-object xwindow *xwindow-table*))
105
106
107 ;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and
108 ;;; its associated object/object-set pair from *port-table* or *xwindow-table*.
109 ;;;
110 (macrolet ((def-remove-object (name table)
111 `(defun ,(intern (concatenate 'simple-string
112 "REMOVE-" (symbol-name name)
113 "-OBJECT"))
114 (,name)
115 ,(format nil
116 "Remove ~A and its associated object/object-set pair."
117 (string-downcase (symbol-name name)))
118 (remhash ,name ,table))))
119 ;(def-remove-object port *port-table*)
120 (def-remove-object xwindow *xwindow-table*))
121
122
123 ;;; Object-Set-Operation -- Public
124 ;;;
125 ;;; Look up the handler function for a given message ID.
126 ;;;
127 (defun object-set-operation (object-set message-id)
128 "Return the handler function in Object-Set for the operation specified by
129 Message-ID, if none, NIL is returned."
130 (check-type object-set object-set)
131 (check-type message-id fixnum)
132 (values (gethash message-id (object-set-table object-set))))
133
134 ;;; %Set-Object-Set-Operation -- Internal
135 ;;;
136 ;;; The setf inverse for Object-Set-Operation.
137 ;;;
138 (defun %set-object-set-operation (object-set message-id new-value)
139 (check-type object-set object-set)
140 (check-type message-id fixnum)
141 (setf (gethash message-id (object-set-table object-set)) new-value))
142 ;;;
143 (defsetf object-set-operation %set-object-set-operation
144 "Sets the handler function for an object set operation.")
145
146
147
148 ;;;; File descriptor IO noise.
149
150 (defstruct (handler
151 (:print-function %print-handler)
152 (:constructor make-handler (direction descriptor function)))
153 ;; Reading or writing...
154 (direction nil :type (member :input :output))
155 ;;
156 ;; File descriptor this handler is tied to.
157 (descriptor 0 :type (mod #.unix:fd-setsize))
158
159 active ; T iff this handler is running.
160 (function nil :type function) ; Function to call.
161 bogus ; T if this descriptor is bogus.
162 )
163
164 (defun %print-handler (handler stream depth)
165 (declare (ignore depth))
166 (format stream "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"
167 (handler-direction handler)
168 (handler-bogus handler)
169 (handler-descriptor handler)
170 (handler-function handler)))
171
172 (defvar *descriptor-handlers* nil
173 "List of all the currently active handlers for file descriptors")
174
175 ;;; ADD-FD-HANDLER -- public
176 ;;;
177 ;;; Add a new handler to *descriptor-handlers*.
178 ;;;
179 (defun add-fd-handler (fd direction function)
180 "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
181 either :INPUT or :OUTPUT. The value returned should be passed to
182 SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
183 (assert (member direction '(:input :output))
184 (direction)
185 "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
186 (let ((handler (make-handler direction fd function)))
187 (push handler *descriptor-handlers*)
188 handler))
189
190 ;;; REMOVE-FD-HANDLER -- public
191 ;;;
192 ;;; Remove an old handler from *descriptor-handlers*.
193 ;;;
194 (defun remove-fd-handler (handler)
195 "Removes HANDLER from the list of active handlers."
196 (setf *descriptor-handlers*
197 (delete handler *descriptor-handlers*
198 :test #'eq)))
199
200 ;;; INVALIDATE-DESCRIPTOR -- public
201 ;;;
202 ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
203 ;;;
204 (defun invalidate-descriptor (fd)
205 "Remove any handers refering to fd. This should only be used when attempting
206 to recover from a detected inconsistancy."
207 (setf *descriptor-handlers*
208 (delete fd *descriptor-handlers*
209 :key #'handler-descriptor)))
210
211 ;;; WITH-FD-HANDLER -- Public.
212 ;;;
213 ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
214 ;;;
215 (defmacro with-fd-handler ((fd direction function) &rest body)
216 "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
217 DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
218 use, and FUNCTION is the function to call whenever FD is usable."
219 (let ((handler (gensym)))
220 `(let (,handler)
221 (unwind-protect
222 (progn
223 (setf ,handler (add-fd-handler ,fd ,direction ,function))
224 ,@body)
225 (when ,handler
226 (remove-fd-handler ,handler))))))
227
228
229 ;;; HANDLER-DESCRIPTORS-ERROR -- Internal.
230 ;;;
231 ;;; First, get a list and mark bad file descriptors. Then signal an error
232 ;;; offering a few restarts.
233 ;;;
234 (defun handler-descriptors-error ()
235 (let ((bogus-handlers nil))
236 (dolist (handler *descriptor-handlers*)
237 (unless (or (handler-bogus handler)
238 (unix:unix-fstat (handler-descriptor handler)))
239 (setf (handler-bogus handler) t)
240 (push handler bogus-handlers)))
241 (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
242 bogus-handlers (length bogus-handlers))
243 (remove-them () :report "Remove bogus handlers."
244 (setf *descriptor-handlers*
245 (delete-if #'handler-bogus *descriptor-handlers*)))
246 (retry-them () :report "Retry bogus handlers."
247 (dolist (handler bogus-handlers)
248 (setf (handler-bogus handler) nil)))
249 (continue () :report "Go on, leaving handlers marked as bogus."))))
250
251
252
253 ;;;; Serve-all-events, serve-event, and friends.
254
255 (declaim (start-block wait-until-fd-usable serve-event serve-all-events))
256
257 ;;; DECODE-TIMEOUT -- Internal
258 ;;;
259 ;;; Break a real timeout into seconds and microseconds.
260 ;;;
261 (defun decode-timeout (timeout)
262 (declare (values (or index null) index))
263 (typecase timeout
264 (integer (values timeout 0))
265 (null (values nil 0))
266 (real
267 (multiple-value-bind (q r)
268 (truncate (coerce timeout 'single-float))
269 (declare (type index q) (single-float r))
270 (values q (the index (truncate (* r 1f6))))))
271 (t
272 (error "Timeout is not a real number or NIL: ~S" timeout))))
273
274
275 ;;; WAIT-UNTIL-FD-USABLE -- Public.
276 ;;;
277 ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
278 ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
279 ;;; timeout at the correct time irrespective of how many events are handled in
280 ;;; the meantime.
281 ;;;
282 (defun wait-until-fd-usable (fd direction &optional timeout)
283 "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
284 :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
285 up."
286 (declare (type (or real null) timeout))
287 (let (usable)
288 (multiple-value-bind (to-sec to-usec)
289 (decode-timeout timeout)
290 (declare (type (or index null) to-sec to-usec))
291 (multiple-value-bind
292 (stop-sec stop-usec)
293 (if to-sec
294 (multiple-value-bind (okay start-sec start-usec)
295 (unix:unix-gettimeofday)
296 (declare (ignore okay))
297 (let ((usec (+ to-usec start-usec))
298 (sec (+ to-sec start-sec)))
299 (declare (type (unsigned-byte 31) usec sec))
300 (if (>= usec 1000000)
301 (values (1+ sec) (- usec 1000000))
302 (values sec usec))))
303 (values 0 0))
304 (declare (type (unsigned-byte 31) stop-sec stop-usec))
305 (with-fd-handler (fd direction #'(lambda (fd)
306 (declare (ignore fd))
307 (setf usable t)))
308 (loop
309 (sub-serve-event to-sec to-usec)
310
311 (when usable
312 (return t))
313
314 (when timeout
315 (multiple-value-bind (okay sec usec)
316 (unix:unix-gettimeofday)
317 (declare (ignore okay))
318 (when (or (> sec stop-sec)
319 (and (= sec stop-sec) (>= usec stop-usec)))
320 (return nil))
321 (setq to-sec (- stop-sec sec))
322 (cond ((> usec stop-usec)
323 (decf to-sec)
324 (setq to-usec (- (+ stop-usec 1000000) usec)))
325 (t
326 (setq to-usec (- stop-usec usec))))))))))))
327
328
329 (defvar *display-event-handlers* nil
330 "This is an alist mapping displays to user functions to be called when
331 SYSTEM:SERVE-EVENT notices input on a display connection. Do not modify
332 this directly; use EXT:ENABLE-CLX-EVENT-HANDLING. A given display
333 should be represented here only once.")
334
335 ;;; SERVE-ALL-EVENTS -- public
336 ;;;
337 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
338 ;;; pending events are processed before returning.
339 ;;;
340 (defun serve-all-events (&optional timeout)
341 "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
342 SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
343 0 until all events have been served. SERVE-ALL-EVENTS returns T if
344 SERVE-EVENT did something and NIL if not."
345 (do ((res nil)
346 (sval (serve-event timeout) (serve-event 0)))
347 ((null sval) res)
348 (setq res t)))
349
350
351 ;;; SERVE-EVENT -- public
352 ;;;
353 ;;; Serve a single event.
354 ;;;
355 (defun serve-event (&optional timeout)
356 "Receive on all ports and Xevents and dispatch to the appropriate handler
357 function. If timeout is specified, server will wait the specified time (in
358 seconds) and then return, otherwise it will wait until something happens.
359 Server returns T if something happened and NIL otherwise."
360 (multiple-value-bind (to-sec to-usec)
361 (decode-timeout timeout)
362 (sub-serve-event to-sec to-usec)))
363
364
365 ;;; Check for any X displays with pending events.
366 ;;;
367 #+clx
368 (defun handle-queued-clx-event ()
369 (dolist (d/h *display-event-handlers*)
370 (let* ((d (car d/h))
371 (disp-fd (fd-stream-fd (xlib::display-input-stream d))))
372 (declare (inline member))
373 ;;
374 ;; If in the *descriptor-handlers*, then we are already waiting for input
375 ;; on that display, and we don't want to do it recursively.
376 (when (and (dolist (hand *descriptor-handlers* t)
377 (when (and (eql (handler-descriptor hand) disp-fd)
378 (not (eq (handler-function hand)
379 #'ext::call-display-event-handler)))
380 (return nil)))
381 (xlib::event-listen d))
382 (handler-bind ((error #'(lambda (condx)
383 (declare (ignore condx))
384 (flush-display-events d))))
385 (unless (funcall (cdr d/h) d)
386 (disable-clx-event-handling d)
387 (error "Event-listen was true, but handler didn't handle: ~%~S"
388 d/h)))
389 (return-from handle-queued-clx-event t)))))
390
391
392 ;;; These macros are chunks of code from SUB-SERVE-EVENT. They randomly
393 ;;; reference the READ-FDS and WRITE-FDS Alien variables (which wold be consed
394 ;;; if passed as function arguments.)
395 ;;;
396 (eval-when (compile eval)
397
398 ;;; CALC-MASKS -- Internal.
399 ;;;
400 ;;; Initialize the fd-sets for UNIX-SELECT and return the active descriptor
401 ;;; count.
402 ;;;
403 (defmacro calc-masks ()
404 '(progn
405 (unix:fd-zero read-fds)
406 (unix:fd-zero write-fds)
407 (let ((count 0))
408 (declare (type index count))
409 (dolist (handler *descriptor-handlers*)
410 (unless (or (handler-active handler)
411 (handler-bogus handler))
412 (let ((fd (handler-descriptor handler)))
413 (ecase (handler-direction handler)
414 (:input (unix:fd-set fd read-fds))
415 (:output (unix:fd-set fd write-fds)))
416 (when (> fd count)
417 (setf count fd)))))
418 (1+ count))))
419
420
421 ;;; Call file descriptor handlers according to the readable and writable masks
422 ;;; returned by select.
423 ;;;
424 (defmacro call-fd-handler ()
425 '(let ((result nil))
426 (dolist (handler *descriptor-handlers*)
427 (let ((desc (handler-descriptor handler)))
428 (when (ecase (handler-direction handler)
429 (:input (unix:fd-isset desc read-fds))
430 (:output (unix:fd-isset desc write-fds)))
431 (unwind-protect
432 (progn
433 ;; Doesn't work -- ACK
434 ;(setf (handler-active handler) t)
435 (funcall (handler-function handler) desc))
436 (setf (handler-active handler) nil))
437 (ecase (handler-direction handler)
438 (:input (unix:fd-clr desc read-fds))
439 (:output (unix:fd-clr desc write-fds)))
440 (setf result t)))
441 result)))
442
443 ); eval-when (compile eval)
444
445
446 ;;; SUB-SERVE-EVENT -- Internal
447 ;;;
448 ;;; Takes timeout broken into seconds and microseconds.
449 ;;;
450 (defun sub-serve-event (to-sec to-usec)
451 #+clx
452 (when (handle-queued-clx-event) (return-from sub-serve-event t))
453
454 ;; Next, wait for something to happen.
455 (alien:with-alien ((read-fds (alien:struct unix:fd-set))
456 (write-fds (alien:struct unix:fd-set)))
457 (let ((count (calc-masks)))
458 (multiple-value-bind
459 (value err)
460 (unix:unix-fast-select
461 count
462 (alien:addr read-fds) (alien:addr write-fds)
463 nil to-sec to-usec)
464
465 ;; Now see what it was (if anything)
466 (cond (value
467 (unless (zerop value) (call-fd-handler)))
468 ((eql err unix:eintr)
469 ;; We did an interrupt.
470 t)
471 (t
472 ;; One of the file descriptors is bad.
473 (handler-descriptors-error)
474 nil))))))
475

  ViewVC Help
Powered by ViewVC 1.1.5