/[cmucl]/src/motif/lisp/callbacks.lisp
ViewVC logotype

Contents of /src/motif/lisp/callbacks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Thu Jun 11 16:04:01 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, merged-unicode-utf16-extfmt-2009-06-11, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, 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, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, portable-clx-import-2009-06-16, cross-sparc-branch-base, intl-branch-base, portable-clx-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: portable-clx-branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.5: +2 -2 lines
Merge Unicode work to trunk.  From label
unicode-utf16-extfmt-2009-06-11.
1 ;;;; -*- Mode: Lisp ; Package: Toolkit -*-
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/motif/lisp/callbacks.lisp,v 1.6 2009/06/11 16:04:01 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Michael Garland
13 ;;;
14 ;;; This file contains all the functions which handle callbacks dispatched
15 ;;; from the C server.
16 ;;;
17
18 (in-package "TOOLKIT")
19
20
21
22 ;;;; Functions for registering deferred actions
23
24 (defvar *callback-deferred-action* nil)
25
26 (defmacro with-callback-deferred-actions (&body forms)
27 `(setf *callback-deferred-action* #'(lambda () ,@forms)))
28
29 (declaim (inline invoke-deferred-actions))
30 (defun invoke-deferred-actions ()
31 (when *callback-deferred-action*
32 (let ((action *callback-deferred-action*))
33 (setf *callback-deferred-action* nil)
34 (funcall action))))
35
36
37
38 ;;;; Functions which track all registered callbacks
39 ;;;
40 ;;; The actual toolkit functions are provided by functions
41 ;;; %add-callback, %remove-callback, etc.
42 ;;;
43 ;;; The callback hash table is keyed on:
44 ;;; (widget-id . callback-name)
45 ;;; The callback data is (fn . client-data)
46
47 (defun add-callback (widget sym-name fn &rest args)
48 "Registers a callback function on the specified widget."
49 (declare (type widget widget)
50 (type (or symbol function) fn)
51 (keyword sym-name))
52 (let* ((name (symbol-resource sym-name))
53 (table (motif-connection-callback-table *motif-connection*))
54 (key (cons (widget-id widget) name))
55 (data (cons fn args)))
56
57 (unless (member sym-name (widget-callbacks widget))
58 (%add-callback widget name)
59 (push sym-name (widget-callbacks widget)))
60 (setf (gethash key table) (cons data (gethash key table)))))
61
62
63 ;; The 'args' list must be EQUAL to the args passed when the callback was
64 ;; created for this callback to be removed.
65
66 (defun remove-callback (widget sym-name fn &rest args)
67 "Removes a callback function from the specified widget."
68 (declare (type widget widget)
69 (type (or symbol function) fn)
70 (keyword sym-name))
71 (let* ((name (symbol-resource sym-name))
72 (table (motif-connection-callback-table *motif-connection*))
73 (key (cons (widget-id widget) name))
74 (data (cons fn args))
75 (new-list (delete data (gethash key table) :test #'equal)))
76
77 (setf (gethash key table) new-list)
78 (unless new-list
79 (%remove-callback widget name)
80 (setf (widget-callbacks widget)
81 (delete sym-name (widget-callbacks widget) :test #'eq)))))
82
83 (defun remove-all-callbacks (widget sym-name)
84 "Removes all callback functions on the specified widget."
85 (declare (type widget widget)
86 (keyword sym-name))
87 (let* ((name (symbol-resource sym-name))
88 (table (motif-connection-callback-table *motif-connection*))
89 (key (cons (widget-id widget) name)))
90 (%remove-callback widget name)
91 (setf (gethash key table) nil)
92 (setf (widget-callbacks widget)
93 (delete sym-name (widget-callbacks widget) :test #'eq))))
94
95 (defun handle-callback (reply)
96 (unwind-protect
97 (let* ((widget (toolkit-read-value reply))
98 (name (toolkit-read-value reply))
99 (table (motif-connection-callback-table *motif-connection*))
100 (calldata (read-callback-info widget reply)))
101 ;; Invoke the callback function
102 (dolist (callback (gethash (cons (widget-id widget) name) table))
103 (apply (car callback)
104 widget
105 calldata
106 (cdr callback))))
107 (unless (motif-connection-terminated *motif-connection*)
108 (terminate-callback)
109 (invoke-deferred-actions))
110 (destroy-message reply)))
111
112
113
114 ;;;; Functions which deal with protocol callbacks
115 ;;;
116 ;;; The protocol table is keyed on:
117 ;;; (widget property protocol)
118 ;;; The data stored in the table is:
119 ;;; (fn . call-data)
120
121 (defun add-protocol-callback (widget property protocol fn &rest args)
122 "Registers a protocol callback function on the specified widget."
123 (declare (type widget widget)
124 (type keyword property protocol)
125 (type (or symbol function) fn))
126 (let* ((property (xti:symbol-atom property))
127 (protocol (xti:symbol-atom protocol))
128 (table (motif-connection-protocol-table *motif-connection*))
129 (key (list (widget-id widget) property protocol))
130 (data (cons fn args)))
131
132 (let ((entry (cons property protocol)))
133 (unless (member entry (widget-protocols widget))
134 (push entry (widget-protocols widget))
135 (%add-protocol-callback widget property protocol)))
136 (setf (gethash key table) (cons data (gethash key table)))))
137
138 (defun remove-protocol-callback (widget property protocol fn &rest args)
139 "Removes a protocol callback function on the specified widget."
140 (declare (type widget widget)
141 (type keyword property protocol)
142 (type (or symbol function) fn))
143 (let* ((property (xti:symbol-atom property))
144 (protocol (xti:symbol-atom protocol))
145 (table (motif-connection-protocol-table *motif-connection*))
146 (key (list (widget-id widget) property protocol))
147 (data (cons fn args))
148 (new-list (delete data (gethash key table) :test #'equal)))
149 (setf (gethash key table) new-list)
150 (unless new-list
151 (%remove-protocol-callback widget property protocol)
152 (setf (widget-protocols widget)
153 (delete (cons property protocol) (widget-protocols widget)
154 :test #'equal)))))
155
156 ;; (declaim (inline add-wm-protocol-callback remove-wm-protocol-callback))
157 (defun add-wm-protocol-callback (widget protocol fn &rest args)
158 "Registers a window manager protocol callback function on the specified
159 widget."
160 (declare (type widget widget)
161 (keyword protocol)
162 (type (or symbol function) fn))
163 (apply #'add-protocol-callback widget :wm-protocols protocol fn args))
164
165 (defun remove-wm-protocol-callback (widget protocol fn &rest args)
166 "Removes a window manager protocol callback function on the specified
167 widget."
168 (declare (type widget widget)
169 (keyword protocol)
170 (type (or symbol function) fn))
171 (apply #'remove-protocol-callback widget :wm-protocols protocol fn args))
172
173 (defun handle-protocol (reply)
174 (unwind-protect
175 (let* ((widget (toolkit-read-value reply))
176 (property (toolkit-read-value reply))
177 (protocol (toolkit-read-value reply))
178 (event (toolkit-read-value reply))
179 (table (motif-connection-protocol-table *motif-connection*))
180 (calldata (make-any-callback :reason :cr-protocols :event event)))
181 (dolist (callback (gethash (list (widget-id widget) property protocol)
182 table))
183 (apply (car callback)
184 widget
185 calldata
186 (cdr callback))))
187 (unless (motif-connection-terminated *motif-connection*)
188 (terminate-callback)
189 (invoke-deferred-actions))
190 (destroy-message reply)))
191
192
193
194 ;;;; Functions for dealing with call-data info
195
196 ;;; These structures are used to hold the various callback information.
197 ;;; When the server begins processing a callback, it will dump the callback
198 ;;; data into the message in slot order. The client will unpack the data
199 ;;; and create a callback structure which will be passed to the Lisp
200 ;;; callback as the call-data. The reason field, possibly together with the
201 ;;; widget class, will be enough to determine what callback structure is
202 ;;; appropriate. The event slot is the (XEvent *) received in C. If the
203 ;;; client wants access to the event, there will be some sort of macro such
204 ;;; as (with-event-info ((<callback-struct>) ... <slots to bind>) ....) or
205 ;;; something. This will be added later.
206 (defstruct (any-callback
207 (:print-function print-callback))
208 (reason :cr-none :type keyword)
209 (event 0 :type (unsigned-byte 32)))
210
211 (defun print-callback (callback stream d)
212 (declare (ignore d)
213 (stream stream))
214 (format stream "#<Motif Callback -- ~a>" (any-callback-reason callback)))
215
216 (defstruct (button-callback
217 (:include any-callback)
218 (:print-function print-callback)
219 (:constructor make-button-callback (reason event click-count)))
220 (click-count 0 :type (unsigned-byte 32))) ; Not always valid data here.
221
222 (defstruct (drawing-area-callback
223 (:include any-callback)
224 (:print-function print-callback)
225 (:constructor make-drawing-area-callback (reason event window)))
226 window)
227
228 (defstruct (drawn-button-callback
229 (:include any-callback)
230 (:print-function print-callback)
231 (:constructor make-drawn-button-callback
232 (reason event window click-count)))
233 window
234 (click-count 0 :type (unsigned-byte 32))) ; Not always valid data here.
235
236 ;;; RowColumnCallbackStruct is weird and probably not necessary
237
238 (defstruct (scroll-bar-callback
239 (:include any-callback)
240 (:print-function print-callback)
241 (:constructor make-scroll-bar-callback (reason event value pixel)))
242 (value 0 :type fixnum)
243 (pixel 0 :type fixnum))
244
245 (defstruct (toggle-button-callback
246 (:include any-callback)
247 (:print-function print-callback)
248 (:constructor make-toggle-button-callback (reason event set)))
249 (set nil :type (member t nil)))
250
251 ;;; ListCallbackStruct is fairly complex
252 (defstruct (list-callback
253 (:include any-callback)
254 (:print-function print-callback)
255 (:constructor make-list-callback (reason event item item-position)))
256 (item nil :type (or null xmstring))
257 (item-position 0 :type fixnum)
258 (selected-items nil :type list) ;; a list of strings (maybe array?)
259 (selected-item-positions nil :type list) ;; of integers
260 (selection-type 0 :type fixnum))
261
262 ;; used for selection-box and command callbacks
263 (defstruct (selection-callback
264 (:include any-callback)
265 (:print-function print-callback)
266 (:constructor make-selection-callback (reason event value)))
267 (value nil :type (or null xmstring)))
268
269 (defstruct (file-selection-callback
270 (:include selection-callback)
271 (:print-function print-callback)
272 (:constructor make-file-selection-callback
273 (reason event value mask dir pattern)))
274 (mask nil :type (or null xmstring))
275 (dir nil :type (or null xmstring))
276 (pattern nil :type (or null xmstring)))
277
278 (defstruct (scale-callback
279 (:include any-callback)
280 (:print-function print-callback)
281 (:constructor make-scale-callback (reason event value)))
282 (value 0 :type fixnum))
283
284 (defstruct (text-callback
285 (:include any-callback)
286 (:print-function print-callback)
287 (:constructor make-text-callback
288 (reason event)))
289 (doit t :type (member t nil))
290 (curr-insert 0 :type fixnum)
291 (new-insert 0 :type fixnum)
292 (start-pos 0 :type fixnum)
293 (end-pos 0 :type fixnum)
294 (text "" :type simple-string)
295 format ;; ***** Don't yet know what this is
296 )
297
298 (defun read-callback-info (widget reply)
299 (let* ((reason (toolkit-read-value reply))
300 (event (toolkit-read-value reply)))
301 (case (widget-type widget)
302 ((:arrow-button :arrow-button-gadget :push-button :push-button-gadget)
303 (make-button-callback reason event (toolkit-read-value reply)))
304 (:drawing-area
305 (make-drawing-area-callback reason event (toolkit-read-value reply)))
306 (:drawn-button
307 (let* ((window (toolkit-read-value reply))
308 (count (toolkit-read-value reply)))
309 (make-drawn-button-callback reason event window count)))
310 (:scroll-bar
311 (let* ((value (toolkit-read-value reply))
312 (pixel (toolkit-read-value reply)))
313 (make-scroll-bar-callback reason event value pixel)))
314 ((:toggle-button :toggle-button-gadget)
315 (make-toggle-button-callback reason event (toolkit-read-value reply)))
316 (:list
317 (let* ((item (toolkit-read-value reply))
318 (item-position (toolkit-read-value reply))
319 (info (make-list-callback reason event item item-position)))
320 (when (or (eq reason :cr-multiple-select)
321 (eq reason :cr-extended-select))
322 (setf (list-callback-selected-items info)
323 (toolkit-read-value reply))
324 (setf (list-callback-selected-item-positions info)
325 (toolkit-read-value reply))
326 (setf (list-callback-selection-type info)
327 (toolkit-read-value reply)))
328 info))
329 (:text
330 (let ((info (make-text-callback reason event)))
331 (when (member reason '(:cr-losing-focus :cr-modifying-text-value
332 :cr-moving-insert-cursor))
333 (setf (text-callback-doit info) (toolkit-read-value reply))
334 (setf (text-callback-curr-insert info) (toolkit-read-value reply))
335 (setf (text-callback-new-insert info) (toolkit-read-value reply))
336
337 (case reason
338 (:cr-losing-focus
339 (setf (text-callback-start-pos info) (toolkit-read-value reply))
340 (setf (text-callback-end-pos info) (toolkit-read-value reply)))
341 (:cr-modifying-text-value
342 (setf (text-callback-start-pos info) (toolkit-read-value reply))
343 (setf (text-callback-end-pos info) (toolkit-read-value reply))
344 (setf (text-callback-text info) (toolkit-read-value reply))
345 (setf (text-callback-format info) (toolkit-read-value reply))
346 )))
347 info))
348 ((:selection-box :command)
349 (make-selection-callback reason event (toolkit-read-value reply)))
350 (:file-selection-box
351 (let* ((value (toolkit-read-value reply))
352 (mask (toolkit-read-value reply))
353 (dir (toolkit-read-value reply))
354 (pattern (toolkit-read-value reply)))
355 (make-file-selection-callback reason event
356 value mask dir pattern)))
357 (:scale
358 (make-scale-callback reason event (toolkit-read-value reply)))
359 (t nil))))
360
361 (defmacro with-callback-event ((event cback) &body forms)
362 `(let ((,event (transport-event (any-callback-event ,cback))))
363 ,@forms))
364
365
366
367 ;;;; Action table support
368
369 (defmacro with-action-event ((event handle) &body forms)
370 `(let ((,event (transport-event ,handle)))
371 ,@forms))
372
373 (defun handle-action (reply)
374 (let* ((widget (toolkit-read-value reply))
375 (event-handle (toolkit-read-value reply))
376 (fun-name (toolkit-read-value reply)))
377 (unwind-protect
378 (funcall (read-from-string fun-name) widget event-handle)
379 (unless (motif-connection-terminated *motif-connection*)
380 (terminate-callback)
381 (invoke-deferred-actions))
382 (destroy-message reply))))
383
384
385
386 ;;;; Functions for managing event handlers
387
388 (defun add-event-handler (widget event-mask non-maskable function &rest args)
389 "Registers an event handler function on the specified widget."
390 (declare (type widget widget)
391 (type (or symbol list) event-mask)
392 (type (member t nil) non-maskable)
393 (type (or symbol function) function))
394 (when (symbolp event-mask)
395 (setf event-mask (list event-mask)))
396 (let ((table (motif-connection-event-table *motif-connection*))
397 (data (cons function args)))
398 (dolist (event-class event-mask)
399 (let ((mask (xlib:make-event-mask event-class))
400 (key (cons (widget-id widget) event-class)))
401
402 (unless (member data (gethash key table) :test #'equal)
403 (push data (gethash key table)))
404 (unless (member event-class (widget-events widget))
405 (push event-class (widget-events widget))
406 (%add-event-handler widget mask nil))))
407 (when non-maskable
408 (let ((mask 0) ; NoEventMask
409 (key (cons (widget-id widget) :non-maskable-mask)))
410 (unless (member data (gethash key table) :test #'equal)
411 (push data (gethash key table)))
412 (unless (member :non-maskable-mask (widget-events widget))
413 (push :non-maskable-mask (widget-events widget))
414 (%add-event-handler widget mask t))))))
415
416 (defun remove-event-handler (widget event-mask non-maskable function &rest args)
417 "Removes an event handler function on the specified widget."
418 (declare (type widget widget)
419 (type (or symbol list) event-mask)
420 (type (member t nil) non-maskable)
421 (type (or symbol function) function))
422 (when (symbolp event-mask)
423 (setf event-mask (list event-mask)))
424 (let ((table (motif-connection-event-table *motif-connection*))
425 (data (cons function args)))
426 (dolist (event-class event-mask)
427 (let* ((mask (xlib:make-event-mask event-class))
428 (key (cons (widget-id widget) event-class))
429 (new-list (delete data (gethash key table) :test #'equal)))
430 (setf (gethash key table) new-list)
431 (unless new-list
432 (setf (widget-events widget)
433 (delete event-class (widget-events widget)))
434 (%remove-event-handler widget mask nil))))
435 (when non-maskable
436 (let* ((mask 0) ; NoEventMask
437 (key (cons (widget-id widget) :non-maskable-mask))
438 (new-list (delete data (gethash key table) :test #'equal)))
439 (setf (gethash key table) new-list)
440 (unless new-list
441 (setf (widget-events widget)
442 (delete :non-maskable-mask (widget-events widget)))
443 (%remove-event-handler widget mask t))))))
444
445 (defun handle-event (reply)
446 (unwind-protect
447 (let* ((widget (toolkit-read-value reply))
448 (mask (toolkit-read-value reply))
449 (nonmaskable (toolkit-read-value reply))
450 (event (toolkit-read-value reply))
451 (table (motif-connection-event-table *motif-connection*))
452 (event-class))
453
454 (setf event-class (if nonmaskable
455 :non-maskable-mask
456 (car (xlib:make-event-keys mask))))
457 (dolist (handler (gethash (cons (widget-id widget) event-class) table))
458 (apply (car handler)
459 widget
460 event
461 (cdr handler))))
462 (unless (motif-connection-terminated *motif-connection*)
463 (terminate-callback)
464 (invoke-deferred-actions))
465 (destroy-message reply)))

  ViewVC Help
Powered by ViewVC 1.1.5