/[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.15 - (show annotations)
Thu Mar 26 03:17:26 1992 UTC (22 years ago) by wlott
Branch: MAIN
Changes since 1.14: +113 -6 lines
Moved object set stuff from lispinit to here.
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.15 1992/03/26 03:17:26 wlott 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 (direction nil :type (member :input :output)) ; Either :input or :output
154 (descriptor 0 :type (mod 32)) ; File descriptor this handler is tied to.
155 active ; T iff this handler is running.
156 (function nil :type function) ; Function to call.
157 bogus ; T if this descriptor is bogus.
158 )
159
160 (defun %print-handler (handler stream depth)
161 (declare (ignore depth))
162 (format stream "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"
163 (handler-direction handler)
164 (handler-bogus handler)
165 (handler-descriptor handler)
166 (handler-function handler)))
167
168 (defvar *descriptor-handlers* nil
169 "List of all the currently active handlers for file descriptors")
170
171
172 ;;; ADD-FD-HANDLER -- public
173 ;;;
174 ;;; Add a new handler to *descriptor-handlers*.
175 ;;;
176 (defun add-fd-handler (fd direction function)
177 "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
178 either :INPUT or :OUTPUT. The value returned should be passed to
179 SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
180 (assert (member direction '(:input :output))
181 (direction)
182 "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
183 (let ((handler (make-handler direction fd function)))
184 (push handler *descriptor-handlers*)
185 handler))
186
187 ;;; REMOVE-FD-HANDLER -- public
188 ;;;
189 ;;; Remove an old handler from *descriptor-handlers*.
190 ;;;
191 (defun remove-fd-handler (handler)
192 "Removes HANDLER from the list of active handlers."
193 (setf *descriptor-handlers*
194 (delete handler *descriptor-handlers*
195 :test #'eq)))
196
197 ;;; INVALIDATE-DESCRIPTOR -- public
198 ;;;
199 ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
200 ;;;
201 (defun invalidate-descriptor (fd)
202 "Remove any handers refering to fd. This should only be used when attempting
203 to recover from a detected inconsistancy."
204 (setf *descriptor-handlers*
205 (delete fd *descriptor-handlers*
206 :key #'handler-descriptor)))
207
208 ;;; WITH-FD-HANDLER -- Public.
209 ;;;
210 ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
211 ;;;
212 (defmacro with-fd-handler ((fd direction function) &rest body)
213 "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
214 DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
215 use, and FUNCTION is the function to call whenever FD is usable."
216 (let ((handler (gensym)))
217 `(let (,handler)
218 (unwind-protect
219 (progn
220 (setf ,handler (add-fd-handler ,fd ,direction ,function))
221 ,@body)
222 (when ,handler
223 (remove-fd-handler ,handler))))))
224
225 ;;; WAIT-UNTIL-FD-USABLE -- Public.
226 ;;;
227 ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
228 ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
229 ;;; timeout at the correct time irrespective of how many events are handled in
230 ;;; the meantime.
231 ;;;
232 (defun wait-until-fd-usable (fd direction &optional timeout)
233 "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
234 :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
235 up."
236 (declare (type (or index null) timeout))
237 (let (usable)
238 (multiple-value-bind
239 (stop-sec stop-usec)
240 (if timeout
241 (multiple-value-bind (okay sec usec)
242 (unix:unix-gettimeofday)
243 (declare (ignore okay))
244 (values (the (unsigned-byte 32) (+ sec timeout))
245 usec))
246 (values 0 0))
247 (declare (type (unsigned-byte 32) stop-sec stop-usec))
248 (with-fd-handler (fd direction #'(lambda (fd)
249 (declare (ignore fd))
250 (setf usable t)))
251 (loop
252 (serve-event timeout)
253
254 (when usable
255 (return t))
256
257 (when timeout
258 (multiple-value-bind (okay sec usec)
259 (unix:unix-gettimeofday)
260 (declare (ignore okay))
261 (when (or (> sec stop-sec)
262 (and (= sec stop-sec) (>= usec stop-usec)))
263 (return nil))
264 (setq timeout (- stop-sec sec)))))))))
265
266
267 ;;; HANDLER-DESCRIPTORS-ERROR -- Internal.
268 ;;;
269 ;;; First, get a list and mark bad file descriptors. Then signal an error
270 ;;; offering a few restarts.
271 ;;;
272 (defun handler-descriptors-error ()
273 (let ((bogus-handlers nil))
274 (dolist (handler *descriptor-handlers*)
275 (unless (or (handler-bogus handler)
276 (unix:unix-fstat (handler-descriptor handler)))
277 (setf (handler-bogus handler) t)
278 (push handler bogus-handlers)))
279 (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
280 bogus-handlers (length bogus-handlers))
281 (remove-them () :report "Remove bogus handlers."
282 (setf *descriptor-handlers*
283 (delete-if #'handler-bogus *descriptor-handlers*)))
284 (retry-them () :report "Retry bogus handlers."
285 (dolist (handler bogus-handlers)
286 (setf (handler-bogus handler) nil)))
287 (continue () :report "Go on, leaving handlers marked as bogus."))))
288
289
290
291 ;;;; Serve-all-events, serve-event, and friends.
292
293 (declaim (start-block serve-event serve-all-events))
294
295 (defvar *display-event-handlers* nil
296 "This is an alist mapping displays to user functions to be called when
297 SYSTEM:SERVE-EVENT notices input on a display connection. Do not modify
298 this directly; use EXT:ENABLE-CLX-EVENT-HANDLING. A given display
299 should be represented here only once.")
300
301 ;;; SERVE-ALL-EVENTS -- public
302 ;;;
303 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
304 ;;; pending events are processed before returning.
305 ;;;
306 (defun serve-all-events (&optional timeout)
307 "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
308 SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
309 0 until all events have been served. SERVE-ALL-EVENTS returns T if
310 SERVE-EVENT did something and NIL if not."
311 (do ((res nil)
312 (sval (serve-event timeout) (serve-event 0)))
313 ((null sval) res)
314 (setq res t)))
315
316
317 ;;; SERVE-EVENT -- public
318 ;;;
319 ;;; Serve a single event.
320 ;;;
321 (defun serve-event (&optional timeout)
322 "Receive on all ports and Xevents and dispatch to the appropriate handler
323 function. If timeout is specified, server will wait the specified time (in
324 seconds) and then return, otherwise it will wait until something happens.
325 Server returns T if something happened and NIL otherwise."
326 ;; First, check any X displays for any pending events.
327 #+clx
328 (dolist (d/h *display-event-handlers*)
329 (let* ((d (car d/h))
330 (disp-fd (fd-stream-fd (xlib::display-input-stream d))))
331 (declare (inline member))
332 ;;
333 ;; If in the *descriptor-handlers*, then we are already waiting for input
334 ;; on that display, and we don't want to do it recursively.
335 (when (and (dolist (hand *descriptor-handlers* t)
336 (when (and (eql (handler-descriptor hand) disp-fd)
337 (not (eq (handler-function hand)
338 #'ext::call-display-event-handler)))
339 (return nil)))
340 (xlib::event-listen d))
341 (handler-bind ((error #'(lambda (condx)
342 (declare (ignore condx))
343 (flush-display-events d))))
344 (unless (funcall (cdr d/h) d)
345 (disable-clx-event-handling d)
346 (error "Event-listen was true, but handler didn't handle: ~%~S"
347 d/h)))
348 (return-from serve-event t))))
349 ;; Next, wait for something to happen.
350 (multiple-value-bind
351 (value readable writeable)
352 (wait-for-event timeout)
353 (declare (type (unsigned-byte 32) readable writeable))
354 ;; Now see what it was (if anything)
355 (cond ((fixnump value)
356 (unless (zerop value)
357 ;; Check the descriptors.
358 (let ((result nil))
359 (dolist (handler *descriptor-handlers*)
360 (when (logbitp (handler-descriptor handler)
361 (ecase (handler-direction handler)
362 (:input readable)
363 (:output writeable)))
364 (unwind-protect
365 (progn
366 ;; Doesn't work -- ACK
367 ;(setf (handler-active handler) t)
368 (funcall (handler-function handler)
369 (handler-descriptor handler)))
370 (setf (handler-active handler) nil))
371 (macrolet ((frob (var)
372 `(setf ,var
373 (logand (32bit-logical-not
374 (ash 1
375 (handler-descriptor
376 handler)))
377 ,var))))
378 (ecase (handler-direction handler)
379 (:input (frob readable))
380 (:output (frob writeable))))
381 (setf result t)))
382 result)))
383 ((eql readable unix:eintr)
384 ;; We did an interrupt.
385 t)
386 (t
387 ;; One of the file descriptors is bad.
388 (handler-descriptors-error)
389 nil))))
390
391
392 ;;; CALC-MASKS -- Internal.
393 ;;;
394 ;;; Return the correct masks to use for UNIX-SELECT. The four return values
395 ;;; are: fd count, read mask, write mask, and exception mask. The exception
396 ;;; mask is currently unused.
397 ;;;
398 (defun calc-masks ()
399 (let ((count 0)
400 (read-mask 0)
401 (write-mask 0)
402 (except-mask 0))
403 (declare (type index count)
404 (type (unsigned-byte 32) read-mask write-mask except-mask))
405 (dolist (handler *descriptor-handlers*)
406 (unless (or (handler-active handler)
407 (handler-bogus handler))
408 (let ((fd (handler-descriptor handler)))
409 (ecase (handler-direction handler)
410 (:input
411 (setf read-mask
412 (logior read-mask
413 (the (unsigned-byte 32) (ash 1 fd)))))
414 (:output
415 (setf write-mask
416 (logior write-mask
417 (the (unsigned-byte 32) (ash 1 fd))))))
418 (when (> fd count)
419 (setf count fd)))))
420 (values (1+ count)
421 read-mask
422 write-mask
423 except-mask)))
424
425 ;;; WAIT-FOR-EVENT -- internal
426 ;;;
427 ;;; Wait for something to happen.
428 ;;;
429 (defun wait-for-event (&optional timeout)
430 "Wait for an something to show up on one of the file descriptors or a message
431 interupt to fire. Timeout is in seconds."
432 (multiple-value-bind
433 (timeout-sec timeout-usec)
434 (typecase timeout
435 (integer (values timeout 0))
436 (null (values nil 0))
437 (t
438 (multiple-value-bind (q r)
439 (truncate (coerce timeout 'single-float))
440 (declare (type index q) (single-float r))
441 (values q (truncate (* r 1f6))))))
442 (declare (type index timeout-usec)
443 (type (or index null) timeout-sec))
444 (multiple-value-bind (count read-mask write-mask except-mask)
445 (calc-masks)
446 ;; Do the select.
447 (unix:unix-select count read-mask write-mask except-mask
448 timeout-sec timeout-usec))))

  ViewVC Help
Powered by ViewVC 1.1.5