/[cmucl]/src/code/clx-ext.lisp
ViewVC logotype

Contents of /src/code/clx-ext.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (show annotations)
Tue Apr 20 17:57:44 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.23: +16 -16 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: Extensions; Log: code.log; Mode: 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 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/clx-ext.lisp,v 1.24 2010/04/20 17:57:44 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains code to extend CLX in the CMU Common Lisp environment.
13 ;;;
14 ;;; Written by Bill Chiles and Chris Hoover.
15 ;;;
16
17 (in-package "EXTENSIONS")
18
19 (intl:textdomain "cmucl")
20
21 (export '(open-clx-display with-clx-event-handling enable-clx-event-handling
22 disable-clx-event-handling object-set-event-handler
23 default-clx-event-handler
24 flush-display-events carefully-add-font-paths
25
26 serve-key-press serve-key-release serve-button-press
27 serve-button-release serve-motion-notify serve-enter-notify
28 serve-leave-notify serve-focus-in serve-focus-out
29 serve-exposure serve-graphics-exposure serve-no-exposure
30 serve-visibility-notify serve-create-notify serve-destroy-notify
31 serve-unmap-notify serve-map-notify serve-map-request
32 serve-reparent-notify serve-configure-notify serve-gravity-notify
33 serve-resize-request serve-configure-request serve-circulate-notify
34 serve-circulate-request serve-property-notify serve-selection-clear
35 serve-selection-request serve-selection-notify serve-colormap-notify
36 serve-client-message))
37
38
39
40 ;;;; OPEN-CLX-DISPLAY.
41
42
43 ;;; New version to interface with "telent-clx".
44 #+(and)
45 (defun open-clx-display (&optional display-name)
46 "Open a connection to DISPLAY-NAME if supplied, or to the appropriate
47 default display as given by GET-DEFAULT-DISPLAY otherwise."
48 (destructuring-bind (host display screen protocol)
49 (xlib::get-default-display display-name)
50 (let ((display (xlib:open-display host :display display :protocol protocol)))
51 (values display
52 (setf (xlib:display-default-screen display)
53 (nth screen (xlib:display-roots display)))))))
54
55
56 #-(and)
57 (defun open-clx-display (&optional (string (cdr (assoc :display
58 *environment-list*
59 :test #'eq))))
60 "Parses the display specifier STRING, including display and screen numbers.
61 STRING defaults to the value of the DISPLAY environment variable. If STRING
62 is non-nil, and any fields are missing in the specification, this signals an
63 error. If you specify a screen, then this sets XLIB:DISPLAY-DEFAULT-SCREEN
64 to that screen since CLX initializes this form to the first of
65 XLIB:SCREEN-ROOTS. Return the display and screen objects."
66 (when string
67 (let* ((string (coerce string 'simple-string))
68 (length (length string))
69 (host-name "")
70 (display-num nil)
71 (screen-num nil))
72 (declare (simple-string string))
73 (let ((colon (position #\: string :test #'char=)))
74 (cond ((null colon)
75 (error (intl:gettext "Missing display number in DISPLAY environment variable.")))
76 (t
77 (unless (zerop colon) (setf host-name (subseq string 0 colon)))
78 (let* ((start (1+ colon))
79 (first-dot (position #\. string
80 :test #'char= :start start)))
81 (cond ((= start (or first-dot length))
82 (error (intl:gettext "Badly formed display number in DISPLAY ~
83 environment variable.")))
84 ((null first-dot)
85 (setf display-num (parse-integer string :start start)))
86 (t
87 (setf display-num (parse-integer string :start start
88 :end first-dot))
89 (let* ((start (1+ first-dot))
90 (second-dot (position #\. string :test #'char=
91 :start start)))
92 (cond ((= start (or second-dot length))
93 (error (intl:gettext "Badly formed screen number in ~
94 DISPLAY environment variable.")))
95 (t
96 (setf screen-num
97 (parse-integer string :start start
98 :end second-dot)))))))))))
99 (let ((display (xlib:open-display host-name :display display-num)))
100 (when screen-num
101 (let* ((screens (xlib:display-roots display))
102 (num-screens (length screens)))
103 (when (>= screen-num num-screens)
104 (xlib:close-display display)
105 (error (intl:gettext "No such screen number (~D).") screen-num))
106 (setf (xlib:display-default-screen display)
107 (elt screens screen-num))))
108 (values display (xlib:display-default-screen display))))))
109
110
111 ;;;; Font Path Manipulation
112
113 (defun carefully-add-font-paths (display font-pathnames
114 &optional (operation :append))
115 "Adds the list of font pathnames, Font-Pathnames, to the font path of
116 the server Display but does so carefully by checking to make sure that
117 the font pathnames are not already on the server's font path. If any
118 of the font pathnames are on the server's font path, they will remain
119 in their current positions. Operation may be specified as either
120 :prepend or :append and specifies whether to add the additional font
121 pathnames to the beginning or the end of the server's original font
122 path."
123 (let ((font-path (xlib:font-path display))
124 (result ()))
125 (dolist (elt font-pathnames)
126 (enumerate-search-list (pathname elt)
127 (lisp::enumerate-matches (name pathname)
128 (unless (member name font-path :test #'string=)
129 (push name result)))))
130 (when result
131 (ecase operation
132 (:prepend
133 (setf (xlib:font-path display) (revappend result font-path)))
134 (:append
135 (setf (xlib:font-path display)
136 (append font-path (nreverse result))))))))
137
138
139 ;;;; Enabling and disabling event handling through SYSTEM:SERVE-EVENT.
140
141 (defvar *clx-fds-to-displays* (make-hash-table :test #'eql)
142 "This is a hash table that maps CLX file descriptors to CLX display
143 structures. For every CLX file descriptor know to SYSTEM:SERVE-EVENT,
144 there must be a mapping from that file descriptor to its CLX display
145 structure when events are handled via SYSTEM:SERVE-EVENT.")
146
147 (defmacro with-clx-event-handling ((display handler) &rest body)
148 "Evaluates body in a context where events are handled for the display
149 by calling handler on the display. This destroys any previously established
150 handler for display."
151 `(unwind-protect
152 (progn
153 (enable-clx-event-handling ,display ,handler)
154 ,@body)
155 (disable-clx-event-handling ,display)))
156
157 ;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in
158 ;;; *display-event-handlers*. It also uses SYSTEM:ADD-FD-HANDLER to have
159 ;;; SYSTEM:SERVE-EVENT call CALL-DISPLAY-EVENT-HANDLER whenever anything shows
160 ;;; up from the display. Since CALL-DISPLAY-EVENT-HANDLER is called on a
161 ;;; file descriptor, the file descriptor is also mapped to the display in
162 ;;; *clx-fds-to-displays*, so the user's handler can be called on the display.
163 ;;;
164 (defun enable-clx-event-handling (display handler)
165 "After calling this, when SYSTEM:SERVE-EVENT notices input on display's
166 connection to the X11 server, handler is called on the display. Handler
167 is invoked in a dynamic context with an error handler bound that will
168 flush all events from the display and return. By returning, it declines
169 to handle the error, but it will have cleared all events; thus, entering
170 the debugger will not result in infinite errors due to streams that wait
171 via SYSTEM:SERVE-EVENT for input. Calling this repeatedly on the same
172 display establishes handler as a new handler, replacing any previous one
173 for display."
174 (check-type display xlib:display)
175 (let ((change-handler (assoc display *display-event-handlers*)))
176 (if change-handler
177 (setf (cdr change-handler) handler)
178 (let ((fd (fd-stream-fd (xlib::display-input-stream display))))
179 (system:add-fd-handler fd :input #'call-display-event-handler)
180 (setf (gethash fd *clx-fds-to-displays*) display)
181 (push (cons display handler) *display-event-handlers*)))))
182
183 ;;; CALL-DISPLAY-EVENT-HANDLER maps the file descriptor to its display and maps
184 ;;; the display to its handler. If we can't find the display, we remove the
185 ;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the
186 ;;; display from *display-event-handlers*. This is necessary to try to keep
187 ;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and
188 ;;; over. This is possible since many CMU Common Lisp streams loop over
189 ;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are
190 ;;; possible.
191 ;;;
192 (defun call-display-event-handler (file-descriptor)
193 (let ((display (gethash file-descriptor *clx-fds-to-displays*)))
194 (unless display
195 (system:invalidate-descriptor file-descriptor)
196 (setf *display-event-handlers*
197 (delete file-descriptor *display-event-handlers*
198 :key #'(lambda (d/h)
199 (fd-stream-fd
200 (xlib::display-input-stream
201 (car d/h))))))
202 (error (intl:gettext "File descriptor ~S not associated with any CLX display.~%~
203 It has been removed from system:serve-event's knowledge.")
204 file-descriptor))
205 (let ((handler (cdr (assoc display *display-event-handlers*))))
206 (unless handler
207 (flush-display-events display)
208 (error (intl:gettext "Display ~S not associated with any event handler.") display))
209 (handler-bind ((error #'(lambda (condx)
210 (declare (ignore condx))
211 (flush-display-events display))))
212 (funcall handler display)))))
213
214 (defun disable-clx-event-handling (display)
215 "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING."
216 (setf *display-event-handlers*
217 (delete display *display-event-handlers* :key #'car))
218 (let ((fd (fd-stream-fd (xlib::display-input-stream display))))
219 (remhash fd *clx-fds-to-displays*)
220 (system:invalidate-descriptor fd)))
221
222
223
224 ;;;; Object set event handling.
225
226 ;;; This is bound by OBJECT-SET-EVENT-HANDLER, so DISPATCH-EVENT can clear
227 ;;; events on the display before signalling any errors. This is necessary
228 ;;; since reading on certain CMU Common Lisp streams involves SERVER, and
229 ;;; getting an error while trying to handle an event causes repeated attempts
230 ;;; to handle the same event.
231 ;;;
232 (defvar *process-clx-event-display* nil)
233
234 (defvar *object-set-event-handler-print* nil)
235
236 (declaim (declaration values))
237
238 (defun object-set-event-handler (display)
239 "This display event handler uses object sets to map event windows cross
240 event types to handlers. It uses XLIB:EVENT-CASE to bind all the slots
241 of each event, calling the handlers on all these values in addition to
242 the event key and send-event-p. Describe EXT:SERVE-MUMBLE, where mumble
243 is an event keyword name for the exact order of arguments.
244 :mapping-notify and :keymap-notify events are ignored since they do not
245 occur on any particular window. After calling a handler, each branch
246 returns t to discard the event. While the handler is executing, all
247 errors go through a handler that flushes all the display's events and
248 returns. This prevents infinite errors since the debug and terminal
249 streams loop over SYSTEM:SERVE-EVENT. This function returns t if there
250 were some event to handle, nil otherwise. It returns immediately if
251 there is no event to handle."
252 (macrolet ((dispatch (event-key &rest args)
253 `(multiple-value-bind (object object-set)
254 (lisp::map-xwindow event-window)
255 (unless object
256 (cond ((not (typep event-window 'xlib:window))
257 (xlib:discard-current-event display)
258 (warn (intl:gettext "Discarding ~S event on non-window ~S.")
259 ,event-key event-window)
260 (return-from object-set-event-handler nil))
261 (t
262 (flush-display-events display)
263 (error (intl:gettext "~S not a known X window.~%~
264 Received event ~S.")
265 event-window ,event-key))))
266 (handler-bind ((error #'(lambda (condx)
267 (declare (ignore condx))
268 (flush-display-events display))))
269 (when *object-set-event-handler-print*
270 (print ,event-key) (force-output))
271 (funcall (gethash ,event-key
272 (lisp::object-set-table object-set)
273 (lisp::object-set-default-handler
274 object-set))
275 object ,event-key
276 ,@args))
277 (setf result t))))
278 (let ((*process-clx-event-display* display)
279 (result nil))
280 (xlib:event-case (display :timeout 0)
281 ((:KEY-PRESS :KEY-RELEASE :BUTTON-PRESS :BUTTON-RELEASE)
282 (event-key event-window root child same-screen-p
283 x y root-x root-y state time code send-event-p)
284 (dispatch event-key event-window root child same-screen-p
285 x y root-x root-y state time code send-event-p))
286 (:MOTION-NOTIFY (event-window root child same-screen-p
287 x y root-x root-y state time hint-p send-event-p)
288 (dispatch :motion-notify event-window root child same-screen-p
289 x y root-x root-y state time hint-p send-event-p))
290 (:ENTER-NOTIFY (event-window root child same-screen-p
291 x y root-x root-y state time mode kind send-event-p)
292 (dispatch :enter-notify event-window root child same-screen-p
293 x y root-x root-y state time mode kind send-event-p))
294 (:LEAVE-NOTIFY (event-window root child same-screen-p
295 x y root-x root-y state time mode kind send-event-p)
296 (dispatch :leave-notify event-window root child same-screen-p
297 x y root-x root-y state time mode kind send-event-p))
298 (:EXPOSURE (event-window x y width height count send-event-p)
299 (dispatch :exposure event-window x y width height count send-event-p))
300 (:GRAPHICS-EXPOSURE (event-window x y width height count major minor
301 send-event-p)
302 (dispatch :graphics-exposure event-window x y width height
303 count major minor send-event-p))
304 (:NO-EXPOSURE (event-window major minor send-event-p)
305 (dispatch :no-exposure event-window major minor send-event-p))
306 (:FOCUS-IN (event-window mode kind send-event-p)
307 (dispatch :focus-in event-window mode kind send-event-p))
308 (:FOCUS-OUT (event-window mode kind send-event-p)
309 (dispatch :focus-out event-window mode kind send-event-p))
310 (:KEYMAP-NOTIFY ()
311 (warn (intl:gettext "Ignoring keymap notify event."))
312 (when *object-set-event-handler-print*
313 (print :keymap-notify) (force-output))
314 (setf result t))
315 (:VISIBILITY-NOTIFY (event-window state send-event-p)
316 (dispatch :visibility-notify event-window state send-event-p))
317 (:CREATE-NOTIFY (event-window window x y width height border-width
318 override-redirect-p send-event-p)
319 (dispatch :create-notify event-window window x y width height
320 border-width override-redirect-p send-event-p))
321 (:DESTROY-NOTIFY (event-window window send-event-p)
322 (dispatch :destroy-notify event-window window send-event-p))
323 (:UNMAP-NOTIFY (event-window window configure-p send-event-p)
324 (dispatch :unmap-notify event-window window configure-p send-event-p))
325 (:MAP-NOTIFY (event-window window override-redirect-p send-event-p)
326 (dispatch :map-notify event-window window override-redirect-p
327 send-event-p))
328 (:MAP-REQUEST (event-window window send-event-p)
329 (dispatch :map-request event-window window send-event-p))
330 (:REPARENT-NOTIFY (event-window window parent x y override-redirect-p
331 send-event-p)
332 (dispatch :reparent-notify event-window window parent x y
333 override-redirect-p send-event-p))
334 (:CONFIGURE-NOTIFY (event-window window x y width height border-width
335 above-sibling override-redirect-p send-event-p)
336 (dispatch :configure-notify event-window window x y width height
337 border-width above-sibling override-redirect-p
338 send-event-p))
339 (:GRAVITY-NOTIFY (event-window window x y send-event-p)
340 (dispatch :gravity-notify event-window window x y send-event-p))
341 (:RESIZE-REQUEST (event-window width height send-event-p)
342 (dispatch :resize-request event-window width height send-event-p))
343 (:CONFIGURE-REQUEST (event-window window x y width height border-width
344 stack-mode above-sibling value-mask send-event-p)
345 (dispatch :configure-request event-window window x y width height
346 border-width stack-mode above-sibling value-mask
347 send-event-p))
348 (:CIRCULATE-NOTIFY (event-window window place send-event-p)
349 (dispatch :circulate-notify event-window window place send-event-p))
350 (:CIRCULATE-REQUEST (event-window window place send-event-p)
351 (dispatch :circulate-request event-window window place send-event-p))
352 (:PROPERTY-NOTIFY (event-window atom state time send-event-p)
353 (dispatch :property-notify event-window atom state time send-event-p))
354 (:SELECTION-CLEAR (event-window selection time send-event-p)
355 (dispatch :selection-notify event-window selection time send-event-p))
356 (:SELECTION-REQUEST (event-window requestor selection target property
357 time send-event-p)
358 (dispatch :selection-request event-window requestor selection target
359 property time send-event-p))
360 (:SELECTION-NOTIFY (event-window selection target property time
361 send-event-p)
362 (dispatch :selection-notify event-window selection target property time
363 send-event-p))
364 (:COLORMAP-NOTIFY (event-window colormap new-p installed-p send-event-p)
365 (dispatch :colormap-notify event-window colormap new-p installed-p
366 send-event-p))
367 (:MAPPING-NOTIFY (request)
368 (warn (intl:gettext "Ignoring mapping notify event -- ~S.") request)
369 (when *object-set-event-handler-print*
370 (print :mapping-notify) (force-output))
371 (setf result t))
372 (:CLIENT-MESSAGE (event-window format data send-event-p)
373 (dispatch :client-message event-window format data send-event-p)))
374 result)))
375
376 (defun default-clx-event-handler (object event-key event-window &rest ignore)
377 (declare (ignore ignore))
378 (flush-display-events *process-clx-event-display*)
379 (error (intl:gettext "No handler for event type ~S on ~S in ~S.")
380 event-key object (lisp::map-xwindow event-window)))
381
382 (defun flush-display-events (display)
383 "Dumps all the events in display's event queue including the current one
384 in case this is called from within XLIB:EVENT-CASE, etc."
385 (xlib:discard-current-event display)
386 (xlib:event-case (display :discard-p t :timeout 0)
387 (t () nil)))
388
389
390
391 ;;;; Key and button service.
392
393 (defun serve-key-press (object-set fun)
394 "Associate a method in the object-set with :key-press events. The method
395 is called on the object the event occurred, event key, event window, root,
396 child, same-screen-p, x, y, root-x, root-y, state, time, code, and
397 send-event-p."
398 (setf (gethash :key-press (lisp::object-set-table object-set)) fun))
399
400 (defun serve-key-release (object-set fun)
401 "Associate a method in the object-set with :key-release events. The method
402 is called on the object the event occurred, event key, event window, root,
403 child, same-screen-p, x, y, root-x, root-y, state, time, code, and
404 send-event-p."
405 (setf (gethash :key-release (lisp::object-set-table object-set)) fun))
406
407 (defun serve-button-press (object-set fun)
408 "Associate a method in the object-set with :button-press events. The method
409 is called on the object the event occurred, event key, event window, root,
410 child, same-screen-p, x, y, root-x, root-y, state, time, code, and
411 send-event-p."
412 (setf (gethash :button-press (lisp::object-set-table object-set)) fun))
413
414 (defun serve-button-release (object-set fun)
415 "Associate a method in the object-set with :button-release events. The
416 method is called on the object the event occurred, event key, event window,
417 root, child, same-screen-p, x, y, root-x, root-y, state, time, code, and
418 send-event-p."
419 (setf (gethash :button-release (lisp::object-set-table object-set)) fun))
420
421
422
423 ;;;; Mouse service.
424
425 (defun serve-motion-notify (object-set fun)
426 "Associate a method in the object-set with :motion-notify events. The method
427 is called on the object the event occurred, event key, event window, root,
428 child, same-screen-p, x, y, root-x, root-y, state, time, hint-p, and
429 send-event-p."
430 (setf (gethash :motion-notify (lisp::object-set-table object-set)) fun))
431
432 (defun serve-enter-notify (object-set fun)
433 "Associate a method in the object-set with :enter-notify events. The method
434 is called on the object the event occurred, event key, event window, root,
435 child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind,
436 and send-event-p."
437 (setf (gethash :enter-notify (lisp::object-set-table object-set)) fun))
438
439 (defun serve-leave-notify (object-set fun)
440 "Associate a method in the object-set with :leave-notify events. The method
441 is called on the object the event occurred, event key, event window, root,
442 child, same-screen-p, x, y, root-x, root-y, state, time, mode, kind,
443 and send-event-p."
444 (setf (gethash :leave-notify (lisp::object-set-table object-set)) fun))
445
446
447
448 ;;;; Keyboard service.
449
450 (defun serve-focus-in (object-set fun)
451 "Associate a method in the object-set with :focus-in events. The method
452 is called on the object the event occurred, event key, event window, mode,
453 kind, and send-event-p."
454 (setf (gethash :focus-in (lisp::object-set-table object-set)) fun))
455
456 (defun serve-focus-out (object-set fun)
457 "Associate a method in the object-set with :focus-out events. The method
458 is called on the object the event occurred, event key, event window, mode,
459 kind, and send-event-p."
460 (setf (gethash :focus-out (lisp::object-set-table object-set)) fun))
461
462
463
464 ;;;; Exposure service.
465
466 (defun serve-exposure (object-set fun)
467 "Associate a method in the object-set with :exposure events. The method
468 is called on the object the event occurred, event key, event window, x, y,
469 width, height, count, and send-event-p."
470 (setf (gethash :exposure (lisp::object-set-table object-set)) fun))
471
472 (defun serve-graphics-exposure (object-set fun)
473 "Associate a method in the object-set with :graphics-exposure events. The
474 method is called on the object the event occurred, event key, event window,
475 x, y, width, height, count, major, minor, and send-event-p."
476 (setf (gethash :graphics-exposure (lisp::object-set-table object-set)) fun))
477
478 (defun serve-no-exposure (object-set fun)
479 "Associate a method in the object-set with :no-exposure events. The method
480 is called on the object the event occurred, event key, event window, major,
481 minor, and send-event-p."
482 (setf (gethash :no-exposure (lisp::object-set-table object-set)) fun))
483
484
485
486 ;;;; Structure service.
487
488 (defun serve-visibility-notify (object-set fun)
489 "Associate a method in the object-set with :visibility-notify events. The
490 method is called on the object the event occurred, event key, event window,
491 state, and send-event-p."
492 (setf (gethash :visibility-notify (lisp::object-set-table object-set)) fun))
493
494 (defun serve-create-notify (object-set fun)
495 "Associate a method in the object-set with :create-notify events. The
496 method is called on the object the event occurred, event key, event window,
497 window, x, y, width, height, border-width, override-redirect-p, and
498 send-event-p."
499 (setf (gethash :create-notify (lisp::object-set-table object-set)) fun))
500
501 (defun serve-destroy-notify (object-set fun)
502 "Associate a method in the object-set with :destroy-notify events. The
503 method is called on the object the event occurred, event key, event window,
504 window, and send-event-p."
505 (setf (gethash :destroy-notify (lisp::object-set-table object-set)) fun))
506
507 (defun serve-unmap-notify (object-set fun)
508 "Associate a method in the object-set with :unmap-notify events. The
509 method is called on the object the event occurred, event key, event window,
510 window, configure-p, and send-event-p."
511 (setf (gethash :unmap-notify (lisp::object-set-table object-set)) fun))
512
513 (defun serve-map-notify (object-set fun)
514 "Associate a method in the object-set with :map-notify events. The
515 method is called on the object the event occurred, event key, event window,
516 window, override-redirect-p, and send-event-p."
517 (setf (gethash :map-notify (lisp::object-set-table object-set)) fun))
518
519 (defun serve-map-request (object-set fun)
520 "Associate a method in the object-set with :map-request events. The
521 method is called on the object the event occurred, event key, event window,
522 window, and send-event-p."
523 (setf (gethash :map-request (lisp::object-set-table object-set)) fun))
524
525 (defun serve-reparent-notify (object-set fun)
526 "Associate a method in the object-set with :reparent-notify events. The
527 method is called on the object the event occurred, event key, event window,
528 window, parent, x, y, override-redirect-p, and send-event-p."
529 (setf (gethash :reparent-notify (lisp::object-set-table object-set)) fun))
530
531 (defun serve-configure-notify (object-set fun)
532 "Associate a method in the object-set with :configure-notify events. The
533 method is called on the object the event occurred, event key, event window,
534 window, x, y, width, height, border-width, above-sibling,
535 override-redirect-p, and send-event-p."
536 (setf (gethash :configure-notify (lisp::object-set-table object-set)) fun))
537
538 (defun serve-gravity-notify (object-set fun)
539 "Associate a method in the object-set with :gravity-notify events. The
540 method is called on the object the event occurred, event key, event window,
541 window, x, y, and send-event-p."
542 (setf (gethash :gravity-notify (lisp::object-set-table object-set)) fun))
543
544 (defun serve-resize-request (object-set fun)
545 "Associate a method in the object-set with :resize-request events. The
546 method is called on the object the event occurred, event key, event window,
547 width, height, and send-event-p."
548 (setf (gethash :resize-request (lisp::object-set-table object-set)) fun))
549
550 (defun serve-configure-request (object-set fun)
551 "Associate a method in the object-set with :configure-request events. The
552 method is called on the object the event occurred, event key, event window,
553 window, x, y, width, height, border-width, stack-mode, above-sibling,
554 value-mask, and send-event-p."
555 (setf (gethash :configure-request (lisp::object-set-table object-set)) fun))
556
557 (defun serve-circulate-notify (object-set fun)
558 "Associate a method in the object-set with :circulate-notify events. The
559 method is called on the object the event occurred, event key, event window,
560 window, place, and send-event-p."
561 (setf (gethash :circulate-notify (lisp::object-set-table object-set)) fun))
562
563 (defun serve-circulate-request (object-set fun)
564 "Associate a method in the object-set with :circulate-request events. The
565 method is called on the object the event occurred, event key, event window,
566 window, place, and send-event-p."
567 (setf (gethash :circulate-request (lisp::object-set-table object-set)) fun))
568
569
570
571 ;;;; Misc. service.
572
573 (defun serve-property-notify (object-set fun)
574 "Associate a method in the object-set with :property-notify events. The
575 method is called on the object the event occurred, event key, event window,
576 atom, state, time, and send-event-p."
577 (setf (gethash :property-notify (lisp::object-set-table object-set)) fun))
578
579 (defun serve-selection-clear (object-set fun)
580 "Associate a method in the object-set with :selection-clear events. The
581 method is called on the object the event occurred, event key, event window,
582 selection, time, and send-event-p."
583 (setf (gethash :selection-clear (lisp::object-set-table object-set)) fun))
584
585 (defun serve-selection-request (object-set fun)
586 "Associate a method in the object-set with :selection-request events. The
587 method is called on the object the event occurred, event key, event window,
588 requestor, selection, target, property, time, and send-event-p."
589 (setf (gethash :selection-request (lisp::object-set-table object-set)) fun))
590
591 (defun serve-selection-notify (object-set fun)
592 "Associate a method in the object-set with :selection-notify events. The
593 method is called on the object the event occurred, event key, event window,
594 selection, target, property, time, and send-event-p."
595 (setf (gethash :selection-notify (lisp::object-set-table object-set)) fun))
596
597 (defun serve-colormap-notify (object-set fun)
598 "Associate a method in the object-set with :colormap-notify events. The
599 method is called on the object the event occurred, event key, event window,
600 colormap, new-p, installed-p, and send-event-p."
601 (setf (gethash :colormap-notify (lisp::object-set-table object-set)) fun))
602
603 (defun serve-client-message (object-set fun)
604 "Associate a method in the object-set with :client-message events. The
605 method is called on the object the event occurred, event key, event window,
606 format, data, and send-event-p."
607 (setf (gethash :client-message (lisp::object-set-table object-set)) fun))

  ViewVC Help
Powered by ViewVC 1.1.5