/[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 - (hide 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 ram 1.1 ;;; -*- Package: Extensions; Log: code.log; Mode: Lisp -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.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 rtoy 1.24 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/clx-ext.lisp,v 1.24 2010/04/20 17:57:44 rtoy Rel $")
9 ram 1.4 ;;;
10 ram 1.1 ;;; **********************************************************************
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 rtoy 1.22 (intl:textdomain "cmucl")
20    
21 ram 1.1 (export '(open-clx-display with-clx-event-handling enable-clx-event-handling
22     disable-clx-event-handling object-set-event-handler
23 ram 1.3 default-clx-event-handler
24 ram 1.1 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 fgilham 1.20
43     ;;; New version to interface with "telent-clx".
44 rtoy 1.21 #+(and)
45 fgilham 1.20 (defun open-clx-display (&optional display-name)
46 rtoy 1.23 "Open a connection to DISPLAY-NAME if supplied, or to the appropriate
47 fgilham 1.20 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 rtoy 1.21 #-(and)
57 ram 1.1 (defun open-clx-display (&optional (string (cdr (assoc :display
58     *environment-list*
59     :test #'eq))))
60 rtoy 1.23 "Parses the display specifier STRING, including display and screen numbers.
61 emarsden 1.19 STRING defaults to the value of the DISPLAY environment variable. If STRING
62 ram 1.1 is non-nil, and any fields are missing in the specification, this signals an
63 chiles 1.5 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 emarsden 1.19 XLIB:SCREEN-ROOTS. Return the display and screen objects."
66 ram 1.1 (when string
67     (let* ((string (coerce string 'simple-string))
68     (length (length string))
69 gerd 1.18 (host-name "")
70 ram 1.1 (display-num nil)
71     (screen-num nil))
72     (declare (simple-string string))
73     (let ((colon (position #\: string :test #'char=)))
74     (cond ((null colon)
75 rtoy 1.24 (error (intl:gettext "Missing display number in DISPLAY environment variable.")))
76 ram 1.1 (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 rtoy 1.24 (error (intl:gettext "Badly formed display number in DISPLAY ~
83     environment variable.")))
84 ram 1.1 ((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 rtoy 1.24 (error (intl:gettext "Badly formed screen number in ~
94     DISPLAY environment variable.")))
95 ram 1.1 (t
96     (setf screen-num
97     (parse-integer string :start start
98     :end second-dot)))))))))))
99 emarsden 1.19 (let ((display (xlib:open-display host-name :display display-num)))
100 chiles 1.5 (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 rtoy 1.24 (error (intl:gettext "No such screen number (~D).") screen-num))
106 chiles 1.5 (setf (xlib:display-default-screen display)
107     (elt screens screen-num))))
108     (values display (xlib:display-default-screen display))))))
109 ram 1.1
110    
111     ;;;; Font Path Manipulation
112    
113     (defun carefully-add-font-paths (display font-pathnames
114     &optional (operation :append))
115 rtoy 1.23 "Adds the list of font pathnames, Font-Pathnames, to the font path of
116 ram 1.1 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 wlott 1.9 (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 ram 1.1 (when result
131     (ecase operation
132     (:prepend
133     (setf (xlib:font-path display) (revappend result font-path)))
134     (:append
135 wlott 1.9 (setf (xlib:font-path display)
136     (append font-path (nreverse result))))))))
137 ram 1.1
138    
139 ram 1.2 ;;;; Enabling and disabling event handling through SYSTEM:SERVE-EVENT.
140 ram 1.1
141     (defvar *clx-fds-to-displays* (make-hash-table :test #'eql)
142 rtoy 1.23 "This is a hash table that maps CLX file descriptors to CLX display
143 ram 1.2 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 ram 1.1
147     (defmacro with-clx-event-handling ((display handler) &rest body)
148 rtoy 1.23 "Evaluates body in a context where events are handled for the display
149 ram 1.1 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 ram 1.2 ;;; *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 ram 1.1 ;;; 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 rtoy 1.23 "After calling this, when SYSTEM:SERVE-EVENT notices input on display's
166 ram 1.2 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 ram 1.1 (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 ram 1.6 (let ((fd (fd-stream-fd (xlib::display-input-stream display))))
179 ram 1.2 (system:add-fd-handler fd :input #'call-display-event-handler)
180 ram 1.1 (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 ram 1.2 ;;; file descriptor using SYSTEM:INVALIDATE-DESCRIPTOR and try to remove the
186 ram 1.1 ;;; display from *display-event-handlers*. This is necessary to try to keep
187 ram 1.2 ;;; SYSTEM:SERVE-EVENT from repeatedly trying to handle the same event over and
188 ram 1.1 ;;; over. This is possible since many CMU Common Lisp streams loop over
189 ram 1.2 ;;; SYSTEM:SERVE-EVENT, so when the debugger is entered, infinite errors are
190 ram 1.1 ;;; possible.
191     ;;;
192     (defun call-display-event-handler (file-descriptor)
193     (let ((display (gethash file-descriptor *clx-fds-to-displays*)))
194     (unless display
195 ram 1.2 (system:invalidate-descriptor file-descriptor)
196 ram 1.1 (setf *display-event-handlers*
197 ram 1.2 (delete file-descriptor *display-event-handlers*
198     :key #'(lambda (d/h)
199 ram 1.7 (fd-stream-fd
200     (xlib::display-input-stream
201     (car d/h))))))
202 rtoy 1.24 (error (intl:gettext "File descriptor ~S not associated with any CLX display.~%~
203     It has been removed from system:serve-event's knowledge.")
204 ram 1.1 file-descriptor))
205     (let ((handler (cdr (assoc display *display-event-handlers*))))
206     (unless handler
207     (flush-display-events display)
208 rtoy 1.24 (error (intl:gettext "Display ~S not associated with any event handler.") display))
209 ram 1.1 (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 rtoy 1.23 "Undoes the effect of EXT:ENABLE-CLX-EVENT-HANDLING."
216 ram 1.1 (setf *display-event-handlers*
217 ram 1.2 (delete display *display-event-handlers* :key #'car))
218 ram 1.6 (let ((fd (fd-stream-fd (xlib::display-input-stream display))))
219 ram 1.1 (remhash fd *clx-fds-to-displays*)
220 ram 1.2 (system:invalidate-descriptor fd)))
221 ram 1.1
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 pw 1.15 (declaim (declaration values))
237 ram 1.1
238     (defun object-set-event-handler (display)
239 rtoy 1.23 "This display event handler uses object sets to map event windows cross
240 ram 1.2 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 ram 1.1 (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 rtoy 1.24 (warn (intl:gettext "Discarding ~S event on non-window ~S.")
259 ram 1.1 ,event-key event-window)
260     (return-from object-set-event-handler nil))
261     (t
262     (flush-display-events display)
263 rtoy 1.24 (error (intl:gettext "~S not a known X window.~%~
264     Received event ~S.")
265 ram 1.1 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 rtoy 1.24 (warn (intl:gettext "Ignoring keymap notify event."))
312 ram 1.1 (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 rtoy 1.24 (warn (intl:gettext "Ignoring mapping notify event -- ~S.") request)
369 ram 1.1 (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 rtoy 1.24 (error (intl:gettext "No handler for event type ~S on ~S in ~S.")
380 ram 1.1 event-key object (lisp::map-xwindow event-window)))
381    
382     (defun flush-display-events (display)
383 rtoy 1.23 "Dumps all the events in display's event queue including the current one
384 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :key-press events. The method
395 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :key-release events. The method
402 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :button-press events. The method
409 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :button-release events. The
416 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :motion-notify events. The method
427 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :enter-notify events. The method
434 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :leave-notify events. The method
441 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :focus-in events. The method
452 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :focus-out events. The method
458 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :exposure events. The method
468 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :graphics-exposure events. The
474 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :no-exposure events. The method
480 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :visibility-notify events. The
490 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :create-notify events. The
496 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :destroy-notify events. The
503 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :unmap-notify events. The
509 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :map-notify events. The
515 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :map-request events. The
521 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :reparent-notify events. The
527 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :configure-notify events. The
533 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :gravity-notify events. The
540 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :resize-request events. The
546 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :configure-request events. The
552 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :circulate-notify events. The
559 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :circulate-request events. The
565 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :property-notify events. The
575 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :selection-clear events. The
581 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :selection-request events. The
587 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :selection-notify events. The
593 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :colormap-notify events. The
599 ram 1.1 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 rtoy 1.23 "Associate a method in the object-set with :client-message events. The
605 ram 1.1 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