/[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.28.12.5 - (hide annotations)
Tue Mar 2 13:45:54 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-branch
CVS Tags: intl-branch-2010-03-18-1300
Changes since 1.28.12.4: +5 -2 lines
Convert strings containing ~:P to use ngettext for proper
translations.
1 ram 1.1 ;;; -*- Log: code.log; Package: LISP -*-
2    
3     ;;; **********************************************************************
4 ram 1.7 ;;; 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     ;;;
7     (ext:file-comment
8 rtoy 1.28.12.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/serve-event.lisp,v 1.28.12.5 2010/03/02 13:45:54 rtoy Exp $")
9 ram 1.7 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; SYSTEM:SERVE-EVENT, now in it's own file.
13     ;;;
14     ;;; Re-written by William Lott, July 1989 - January 1990.
15     ;;;
16     ;;; **********************************************************************
17    
18     (in-package "SYSTEM")
19    
20 rtoy 1.28.12.1 (intl:textdomain "cmucl")
21    
22 ram 1.1 (export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor
23 wlott 1.15 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 ram 1.1
27 ram 1.2 (in-package "EXTENSIONS")
28    
29     (export '(*display-event-handlers*))
30    
31 ram 1.1 (in-package "LISP")
32    
33    
34    
35 wlott 1.15 ;;;; Object set stuff.
36 ram 1.1
37 wlott 1.15 ;;;
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 rtoy 1.28.12.2 _"Make an object set for use by a RPC/xevent server. Name is for
61 wlott 1.15 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 rtoy 1.28.12.2 (error _"You lose, object: ~S" object))
69 wlott 1.15
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 rtoy 1.28.12.2 _N"Return the handler function in Object-Set for the operation specified by
129 wlott 1.15 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 rtoy 1.28.12.2 _N"Sets the handler function for an object set operation.")
145 ram 1.1
146 wlott 1.3
147 ram 1.1
148     ;;;; File descriptor IO noise.
149    
150     (defstruct (handler
151     (:print-function %print-handler)
152     (:constructor make-handler (direction descriptor function)))
153 ram 1.20 ;; 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 ram 1.1 active ; T iff this handler is running.
160 ram 1.8 (function nil :type function) ; Function to call.
161 ram 1.1 bogus ; T if this descriptor is bogus.
162     )
163    
164     (defun %print-handler (handler stream depth)
165     (declare (ignore depth))
166 rtoy 1.28.12.2 (format stream _"#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"
167 ram 1.1 (handler-direction handler)
168     (handler-bogus handler)
169     (handler-descriptor handler)
170     (handler-function handler)))
171    
172     (defvar *descriptor-handlers* nil
173 rtoy 1.28.12.2 _N"List of all the currently active handlers for file descriptors")
174 ram 1.1
175     ;;; ADD-FD-HANDLER -- public
176     ;;;
177     ;;; Add a new handler to *descriptor-handlers*.
178     ;;;
179     (defun add-fd-handler (fd direction function)
180 rtoy 1.28.12.2 _N"Arange to call FUNCTION whenever FD is usable. DIRECTION should be
181 ram 1.1 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 rtoy 1.28.12.2 _"Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
186 ram 1.1 (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 rtoy 1.28.12.2 _N"Removes HANDLER from the list of active handlers."
196 ram 1.1 (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 rtoy 1.28.12.2 _N"Remove any handers refering to FD. This should only be used when attempting
206 emarsden 1.26 to recover from a detected inconsistency."
207 ram 1.1 (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 rtoy 1.28.12.2 _N"Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
217 ram 1.1 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 wlott 1.14 (unix:unix-fstat (handler-descriptor handler)))
239 ram 1.1 (setf (handler-bogus handler) t)
240     (push handler bogus-handlers)))
241 rtoy 1.28.12.5 ;; TRANSLATORS: This needs more work.
242     (restart-case (error (intl:ngettext "~S ~[have~;has a~:;have~] bad file descriptor."
243     "~S ~[have~;has a~:;have~] bad file descriptors."
244     (length bogus-handlers))
245 ram 1.1 bogus-handlers (length bogus-handlers))
246 rtoy 1.28.12.3 (remove-them ()
247 rtoy 1.28.12.4 :report (lambda (stream)
248 rtoy 1.28.12.3 (write-string _"Remove bogus handlers." stream))
249 ram 1.1 (setf *descriptor-handlers*
250     (delete-if #'handler-bogus *descriptor-handlers*)))
251 rtoy 1.28.12.3 (retry-them ()
252 rtoy 1.28.12.4 :report (lambda (stream)
253 rtoy 1.28.12.3 (write-string _"Retry bogus handlers." stream))
254 ram 1.1 (dolist (handler bogus-handlers)
255     (setf (handler-bogus handler) nil)))
256 rtoy 1.28.12.3 (continue ()
257 rtoy 1.28.12.4 :report (lambda (stream)
258 rtoy 1.28.12.3 (write-string _"Go on, leaving handlers marked as bogus." stream))))))
259 ram 1.1
260    
261    
262     ;;;; Serve-all-events, serve-event, and friends.
263    
264 ram 1.20 (declaim (start-block wait-until-fd-usable serve-event serve-all-events))
265 ram 1.8
266 ram 1.16 ;;; DECODE-TIMEOUT -- Internal
267     ;;;
268     ;;; Break a real timeout into seconds and microseconds.
269     ;;;
270     (defun decode-timeout (timeout)
271     (declare (values (or index null) index))
272     (typecase timeout
273     (integer (values timeout 0))
274     (null (values nil 0))
275     (real
276     (multiple-value-bind (q r)
277     (truncate (coerce timeout 'single-float))
278     (declare (type index q) (single-float r))
279 dtc 1.25 (values q (the (values index t) (truncate (* r 1f6))))))
280 ram 1.16 (t
281 rtoy 1.28.12.2 (error _"Timeout is not a real number or NIL: ~S" timeout))))
282 ram 1.16
283    
284     ;;; WAIT-UNTIL-FD-USABLE -- Public.
285     ;;;
286     ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
287     ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
288     ;;; timeout at the correct time irrespective of how many events are handled in
289     ;;; the meantime.
290     ;;;
291     (defun wait-until-fd-usable (fd direction &optional timeout)
292 rtoy 1.28.12.2 _N"Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
293 ram 1.16 :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
294     up."
295     (declare (type (or real null) timeout))
296     (let (usable)
297     (multiple-value-bind (to-sec to-usec)
298     (decode-timeout timeout)
299     (declare (type (or index null) to-sec to-usec))
300     (multiple-value-bind
301     (stop-sec stop-usec)
302     (if to-sec
303     (multiple-value-bind (okay start-sec start-usec)
304     (unix:unix-gettimeofday)
305     (declare (ignore okay))
306     (let ((usec (+ to-usec start-usec))
307     (sec (+ to-sec start-sec)))
308     (declare (type (unsigned-byte 31) usec sec))
309     (if (>= usec 1000000)
310     (values (1+ sec) (- usec 1000000))
311     (values sec usec))))
312     (values 0 0))
313     (declare (type (unsigned-byte 31) stop-sec stop-usec))
314     (with-fd-handler (fd direction #'(lambda (fd)
315     (declare (ignore fd))
316     (setf usable t)))
317     (loop
318     (sub-serve-event to-sec to-usec)
319    
320     (when usable
321     (return t))
322    
323     (when timeout
324     (multiple-value-bind (okay sec usec)
325     (unix:unix-gettimeofday)
326     (declare (ignore okay))
327     (when (or (> sec stop-sec)
328     (and (= sec stop-sec) (>= usec stop-usec)))
329     (return nil))
330     (setq to-sec (- stop-sec sec))
331 ram 1.17 (cond ((> usec stop-usec)
332     (decf to-sec)
333     (setq to-usec (- (+ stop-usec 1000000) usec)))
334     (t
335     (setq to-usec (- stop-usec usec))))))))))))
336 ram 1.16
337    
338 ram 1.2 (defvar *display-event-handlers* nil
339 rtoy 1.28.12.2 _N"This is an alist mapping displays to user functions to be called when
340 ram 1.2 SYSTEM:SERVE-EVENT notices input on a display connection. Do not modify
341     this directly; use EXT:ENABLE-CLX-EVENT-HANDLING. A given display
342     should be represented here only once.")
343    
344 ram 1.1 ;;; SERVE-ALL-EVENTS -- public
345     ;;;
346     ;;; Wait for up to timeout seconds for an event to happen. Make sure all
347     ;;; pending events are processed before returning.
348     ;;;
349     (defun serve-all-events (&optional timeout)
350 rtoy 1.28.12.2 _N"SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
351 ram 1.1 SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
352     0 until all events have been served. SERVE-ALL-EVENTS returns T if
353     SERVE-EVENT did something and NIL if not."
354     (do ((res nil)
355     (sval (serve-event timeout) (serve-event 0)))
356     ((null sval) res)
357     (setq res t)))
358    
359 ram 1.2
360 ram 1.1 ;;; SERVE-EVENT -- public
361     ;;;
362     ;;; Serve a single event.
363     ;;;
364     (defun serve-event (&optional timeout)
365 rtoy 1.28.12.2 _N"Receive on all ports and Xevents and dispatch to the appropriate handler
366 ram 1.1 function. If timeout is specified, server will wait the specified time (in
367     seconds) and then return, otherwise it will wait until something happens.
368     Server returns T if something happened and NIL otherwise."
369 ram 1.16 (multiple-value-bind (to-sec to-usec)
370     (decode-timeout timeout)
371     (sub-serve-event to-sec to-usec)))
372    
373    
374     ;;; Check for any X displays with pending events.
375     ;;;
376     (defun handle-queued-clx-event ()
377 ram 1.2 (dolist (d/h *display-event-handlers*)
378 ram 1.11 (let* ((d (car d/h))
379     (disp-fd (fd-stream-fd (xlib::display-input-stream d))))
380 ram 1.9 (declare (inline member))
381     ;;
382     ;; If in the *descriptor-handlers*, then we are already waiting for input
383     ;; on that display, and we don't want to do it recursively.
384 ram 1.11 (when (and (dolist (hand *descriptor-handlers* t)
385     (when (and (eql (handler-descriptor hand) disp-fd)
386     (not (eq (handler-function hand)
387     #'ext::call-display-event-handler)))
388     (return nil)))
389 ram 1.9 (xlib::event-listen d))
390 ram 1.1 (handler-bind ((error #'(lambda (condx)
391     (declare (ignore condx))
392     (flush-display-events d))))
393 ram 1.12 (unless (funcall (cdr d/h) d)
394 ram 1.13 (disable-clx-event-handling d)
395 rtoy 1.28.12.2 (error _"Event-listen was true, but handler didn't handle: ~%~S"
396 ram 1.12 d/h)))
397 ram 1.16 (return-from handle-queued-clx-event t)))))
398    
399    
400 ram 1.20 ;;; These macros are chunks of code from SUB-SERVE-EVENT. They randomly
401 rtoy 1.28 ;;; reference the READ-FDS and WRITE-FDS Alien variables (which would be consed
402 ram 1.20 ;;; if passed as function arguments.)
403     ;;;
404     (eval-when (compile eval)
405    
406     ;;; CALC-MASKS -- Internal.
407     ;;;
408     ;;; Initialize the fd-sets for UNIX-SELECT and return the active descriptor
409     ;;; count.
410     ;;;
411 emarsden 1.27 ;;; Ideally we would mask out descriptors whose handler is already
412     ;;; active, since handler functions may not be reentrant.
413     ;;; Unfortunately, this would not be compatible with the way that
414     ;;; Hemlock's slave lisp mechanism interacts with the WIRE facility:
415     ;;; requests sent to the slave lisp may require a call to the master
416     ;;; lisp over the same wire.
417 ram 1.20 (defmacro calc-masks ()
418     '(progn
419     (unix:fd-zero read-fds)
420     (unix:fd-zero write-fds)
421     (let ((count 0))
422     (declare (type index count))
423     (dolist (handler *descriptor-handlers*)
424 emarsden 1.27 (unless (or ; (handler-active handler)
425 ram 1.20 (handler-bogus handler))
426     (let ((fd (handler-descriptor handler)))
427     (ecase (handler-direction handler)
428     (:input (unix:fd-set fd read-fds))
429     (:output (unix:fd-set fd write-fds)))
430     (when (> fd count)
431     (setf count fd)))))
432     (1+ count))))
433    
434    
435 ram 1.16 ;;; Call file descriptor handlers according to the readable and writable masks
436     ;;; returned by select.
437     ;;;
438 ram 1.20 (defmacro call-fd-handler ()
439     '(let ((result nil))
440     (dolist (handler *descriptor-handlers*)
441     (let ((desc (handler-descriptor handler)))
442     (when (ecase (handler-direction handler)
443     (:input (unix:fd-isset desc read-fds))
444     (:output (unix:fd-isset desc write-fds)))
445     (unwind-protect
446     (progn
447 emarsden 1.26 (setf (handler-active handler) t)
448 ram 1.20 (funcall (handler-function handler) desc))
449     (setf (handler-active handler) nil))
450     (ecase (handler-direction handler)
451     (:input (unix:fd-clr desc read-fds))
452     (:output (unix:fd-clr desc write-fds)))
453 emarsden 1.26 (setf result t))))
454     result))
455 ram 1.16
456 ram 1.20 ); eval-when (compile eval)
457 ram 1.16
458 dtc 1.23 ;;; When a *periodic-polling-function* is defined the server will not
459     ;;; block for more than the maximum event timeout and will call the
460 rtoy 1.28 ;;; polling function if it does time out. One important use of this
461 dtc 1.23 ;;; is to periodically call process-yield.
462     ;;;
463     (declaim (type (or null function) *periodic-polling-function*))
464     (defvar *periodic-polling-function*
465     #-mp nil #+mp #'mp:process-yield)
466     (declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))
467     (defvar *max-event-to-sec* 1)
468     (defvar *max-event-to-usec* 0)
469 ram 1.20
470 ram 1.16 ;;; SUB-SERVE-EVENT -- Internal
471     ;;;
472     ;;; Takes timeout broken into seconds and microseconds.
473     ;;;
474     (defun sub-serve-event (to-sec to-usec)
475 dtc 1.23 (declare (type (or null (unsigned-byte 29)) to-sec to-usec))
476    
477 ram 1.20 (when (handle-queued-clx-event) (return-from sub-serve-event t))
478 dtc 1.23
479     (let ((call-polling-fn nil))
480     (when (and *periodic-polling-function*
481     ;; Enforce a maximum timeout.
482     (or (null to-sec)
483     (> to-sec *max-event-to-sec*)
484     (and (= to-sec *max-event-to-sec*)
485     (> to-usec *max-event-to-usec*))))
486     (setf to-sec *max-event-to-sec*)
487     (setf to-usec *max-event-to-usec*)
488     (setf call-polling-fn t))
489    
490     ;; Next, wait for something to happen.
491     (alien:with-alien ((read-fds (alien:struct unix:fd-set))
492     (write-fds (alien:struct unix:fd-set)))
493     (let ((count (calc-masks)))
494     (multiple-value-bind
495     (value err)
496     (unix:unix-fast-select
497     count
498     (alien:addr read-fds) (alien:addr write-fds)
499     nil to-sec to-usec)
500 ram 1.20
501 dtc 1.23 ;; Now see what it was (if anything)
502     (cond (value
503     (cond ((zerop value)
504     ;; Timed out.
505     (when call-polling-fn
506     (funcall *periodic-polling-function*)))
507     (t
508     (call-fd-handler))))
509     ((eql err unix:eintr)
510     ;; We did an interrupt.
511     t)
512     (t
513     ;; One of the file descriptors is bad.
514     (handler-descriptors-error)
515     nil)))))))
516 ram 1.1

  ViewVC Help
Powered by ViewVC 1.1.5