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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.28 by rtoy, Thu Jun 11 16:03:59 2009 UTC revision 1.28.12.3 by rtoy, Wed Feb 10 14:07:36 2010 UTC
# Line 17  Line 17 
17    
18  (in-package "SYSTEM")  (in-package "SYSTEM")
19    
20    (intl:textdomain "cmucl")
21    
22  (export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor  (export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor
23            serve-event serve-all-events wait-until-fd-usable            serve-event serve-all-events wait-until-fd-usable
24            make-object-set object-set-operation *xwindow-table*            make-object-set object-set-operation *xwindow-table*
# Line 55  Line 57 
57    default-handler)    default-handler)
58    
59  (setf (documentation 'make-object-set 'function)  (setf (documentation 'make-object-set 'function)
60        "Make an object set for use by a RPC/xevent server.  Name is for        _"Make an object set for use by a RPC/xevent server.  Name is for
61        descriptive purposes only.")        descriptive purposes only.")
62    
63  ;;; Default-Default-Handler  --  Internal  ;;; Default-Default-Handler  --  Internal
# Line 63  Line 65 
65  ;;;    If no such operation defined, signal an error.  ;;;    If no such operation defined, signal an error.
66  ;;;  ;;;
67  (defun default-default-handler (object)  (defun default-default-handler (object)
68    (error "You lose, object: ~S" object))    (error _"You lose, object: ~S" object))
69    
70    
71  ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and  ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
# Line 123  Line 125 
125  ;;;    Look up the handler function for a given message ID.  ;;;    Look up the handler function for a given message ID.
126  ;;;  ;;;
127  (defun object-set-operation (object-set message-id)  (defun object-set-operation (object-set message-id)
128    "Return the handler function in Object-Set for the operation specified by    _N"Return the handler function in Object-Set for the operation specified by
129     Message-ID, if none, NIL is returned."     Message-ID, if none, NIL is returned."
130    (check-type object-set object-set)    (check-type object-set object-set)
131    (check-type message-id fixnum)    (check-type message-id fixnum)
# Line 139  Line 141 
141    (setf (gethash message-id (object-set-table object-set)) new-value))    (setf (gethash message-id (object-set-table object-set)) new-value))
142  ;;;  ;;;
143  (defsetf object-set-operation %set-object-set-operation  (defsetf object-set-operation %set-object-set-operation
144    "Sets the handler function for an object set operation.")    _N"Sets the handler function for an object set operation.")
145    
146    
147    
# Line 161  Line 163 
163    
164  (defun %print-handler (handler stream depth)  (defun %print-handler (handler stream depth)
165    (declare (ignore depth))    (declare (ignore depth))
166    (format stream "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"    (format stream _"#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"
167            (handler-direction handler)            (handler-direction handler)
168            (handler-bogus handler)            (handler-bogus handler)
169            (handler-descriptor handler)            (handler-descriptor handler)
170            (handler-function handler)))            (handler-function handler)))
171    
172  (defvar *descriptor-handlers* nil  (defvar *descriptor-handlers* nil
173    "List of all the currently active handlers for file descriptors")    _N"List of all the currently active handlers for file descriptors")
174    
175  ;;; ADD-FD-HANDLER -- public  ;;; ADD-FD-HANDLER -- public
176  ;;;  ;;;
177  ;;;   Add a new handler to *descriptor-handlers*.  ;;;   Add a new handler to *descriptor-handlers*.
178  ;;;  ;;;
179  (defun add-fd-handler (fd direction function)  (defun add-fd-handler (fd direction function)
180    "Arange to call FUNCTION whenever FD is usable. DIRECTION should be    _N"Arange to call FUNCTION whenever FD is usable. DIRECTION should be
181    either :INPUT or :OUTPUT. The value returned should be passed to    either :INPUT or :OUTPUT. The value returned should be passed to
182    SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."    SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
183    (assert (member direction '(:input :output))    (assert (member direction '(:input :output))
184            (direction)            (direction)
185            "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)            _"Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
186    (let ((handler (make-handler direction fd function)))    (let ((handler (make-handler direction fd function)))
187      (push handler *descriptor-handlers*)      (push handler *descriptor-handlers*)
188      handler))      handler))
# Line 190  Line 192 
192  ;;;   Remove an old handler from *descriptor-handlers*.  ;;;   Remove an old handler from *descriptor-handlers*.
193  ;;;  ;;;
194  (defun remove-fd-handler (handler)  (defun remove-fd-handler (handler)
195    "Removes HANDLER from the list of active handlers."    _N"Removes HANDLER from the list of active handlers."
196    (setf *descriptor-handlers*    (setf *descriptor-handlers*
197          (delete handler *descriptor-handlers*          (delete handler *descriptor-handlers*
198                  :test #'eq)))                  :test #'eq)))
# Line 200  Line 202 
202  ;;;   Search *descriptor-handlers* for any reference to fd, and nuke 'em.  ;;;   Search *descriptor-handlers* for any reference to fd, and nuke 'em.
203  ;;;  ;;;
204  (defun invalidate-descriptor (fd)  (defun invalidate-descriptor (fd)
205    "Remove any handers refering to FD. This should only be used when attempting    _N"Remove any handers refering to FD. This should only be used when attempting
206    to recover from a detected inconsistency."    to recover from a detected inconsistency."
207    (setf *descriptor-handlers*    (setf *descriptor-handlers*
208          (delete fd *descriptor-handlers*          (delete fd *descriptor-handlers*
# Line 211  Line 213 
213  ;;; Add the handler to *descriptor-handlers* for the duration of BODY.  ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
214  ;;;  ;;;
215  (defmacro with-fd-handler ((fd direction function) &rest body)  (defmacro with-fd-handler ((fd direction function) &rest body)
216    "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.    _N"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     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."     use, and FUNCTION is the function to call whenever FD is usable."
219    (let ((handler (gensym)))    (let ((handler (gensym)))
# Line 238  Line 240 
240          (push handler bogus-handlers)))          (push handler bogus-handlers)))
241      (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."      (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
242                           bogus-handlers (length bogus-handlers))                           bogus-handlers (length bogus-handlers))
243        (remove-them () :report "Remove bogus handlers."        (remove-them ()
244            :report (lambda (condition stream)
245                      (declare (ignore condition))
246                      (write-string _"Remove bogus handlers." stream))
247         (setf *descriptor-handlers*         (setf *descriptor-handlers*
248               (delete-if #'handler-bogus *descriptor-handlers*)))               (delete-if #'handler-bogus *descriptor-handlers*)))
249        (retry-them () :report "Retry bogus handlers."        (retry-them ()
250            :report (lambda (condition stream)
251                      (declare (ignore condition))
252                      (write-string _"Retry bogus handlers." stream))
253         (dolist (handler bogus-handlers)         (dolist (handler bogus-handlers)
254           (setf (handler-bogus handler) nil)))           (setf (handler-bogus handler) nil)))
255        (continue () :report "Go on, leaving handlers marked as bogus."))))        (continue ()
256            :report (lambda (condition stream)
257                      (declare (ignore condition))
258                      (write-string _"Go on, leaving handlers marked as bogus." stream))))))
259    
260    
261    
# Line 267  Line 278 
278         (declare (type index q) (single-float r))         (declare (type index q) (single-float r))
279         (values q (the (values index t) (truncate (* r 1f6))))))         (values q (the (values index t) (truncate (* r 1f6))))))
280      (t      (t
281       (error "Timeout is not a real number or NIL: ~S" timeout))))       (error _"Timeout is not a real number or NIL: ~S" timeout))))
282    
283    
284  ;;; WAIT-UNTIL-FD-USABLE -- Public.  ;;; WAIT-UNTIL-FD-USABLE -- Public.
# Line 278  Line 289 
289  ;;; the meantime.  ;;; the meantime.
290  ;;;  ;;;
291  (defun wait-until-fd-usable (fd direction &optional timeout)  (defun wait-until-fd-usable (fd direction &optional timeout)
292    "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or    _N"Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
293    :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving    :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
294    up."    up."
295    (declare (type (or real null) timeout))    (declare (type (or real null) timeout))
# Line 325  Line 336 
336    
337    
338  (defvar *display-event-handlers* nil  (defvar *display-event-handlers* nil
339    "This is an alist mapping displays to user functions to be called when    _N"This is an alist mapping displays to user functions to be called when
340     SYSTEM:SERVE-EVENT notices input on a display connection.  Do not modify     SYSTEM:SERVE-EVENT notices input on a display connection.  Do not modify
341     this directly; use EXT:ENABLE-CLX-EVENT-HANDLING.  A given display     this directly; use EXT:ENABLE-CLX-EVENT-HANDLING.  A given display
342     should be represented here only once.")     should be represented here only once.")
# Line 336  Line 347 
347  ;;; pending events are processed before returning.  ;;; pending events are processed before returning.
348  ;;;  ;;;
349  (defun serve-all-events (&optional timeout)  (defun serve-all-events (&optional timeout)
350    "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout.  If    _N"SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout.  If
351    SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout    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    0 until all events have been served.  SERVE-ALL-EVENTS returns T if
353    SERVE-EVENT did something and NIL if not."    SERVE-EVENT did something and NIL if not."
# Line 351  Line 362 
362  ;;;   Serve a single event.  ;;;   Serve a single event.
363  ;;;  ;;;
364  (defun serve-event (&optional timeout)  (defun serve-event (&optional timeout)
365    "Receive on all ports and Xevents and dispatch to the appropriate handler    _N"Receive on all ports and Xevents and dispatch to the appropriate handler
366    function.  If timeout is specified, server will wait the specified time (in    function.  If timeout is specified, server will wait the specified time (in
367    seconds) and then return, otherwise it will wait until something happens.    seconds) and then return, otherwise it will wait until something happens.
368    Server returns T if something happened and NIL otherwise."    Server returns T if something happened and NIL otherwise."
# Line 381  Line 392 
392                                    (flush-display-events d))))                                    (flush-display-events d))))
393            (unless (funcall (cdr d/h) d)            (unless (funcall (cdr d/h) d)
394              (disable-clx-event-handling d)              (disable-clx-event-handling d)
395              (error "Event-listen was true, but handler didn't handle: ~%~S"              (error _"Event-listen was true, but handler didn't handle: ~%~S"
396                     d/h)))                     d/h)))
397          (return-from handle-queued-clx-event t)))))          (return-from handle-queued-clx-event t)))))
398    

Legend:
Removed from v.1.28  
changed lines
  Added in v.1.28.12.3

  ViewVC Help
Powered by ViewVC 1.1.5