chiark / gitweb /
Comment out code removed, updated to new reference api
[clg] / glib / gcallback.lisp
CommitLineData
112ac1d3 1;; Common Lisp bindings for GTK+ v2.x
2;; Copyright 2000 Espen S. Johnsen <espen@users.sf.net>
c8c48a4c 3;;
112ac1d3 4;; Permission is hereby granted, free of charge, to any person obtaining
5;; a copy of this software and associated documentation files (the
6;; "Software"), to deal in the Software without restriction, including
7;; without limitation the rights to use, copy, modify, merge, publish,
8;; distribute, sublicense, and/or sell copies of the Software, and to
9;; permit persons to whom the Software is furnished to do so, subject to
10;; the following conditions:
c8c48a4c 11;;
112ac1d3 12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
c8c48a4c 14;;
112ac1d3 15;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
248f4dd7 23;; $Id: gcallback.lisp,v 1.33 2006-03-02 21:13:01 espen Exp $
c8c48a4c 24
25(in-package "GLIB")
26
27(use-prefix "g")
28
29
e0d2987b 30;;;; Callback invokation
c8c48a4c 31
6851535e 32(deftype gclosure () 'pointer)
33(register-type 'gclosure '|g_closure_get_type|)
34
e378b861 35(defun register-callback-function (function)
36 (check-type function (or null symbol function))
37 (register-user-data function))
c8c48a4c 38
e0d2987b 39;; Callback marshal for regular signal handlers
56ccd5b7 40(define-callback closure-marshal nil
41 ((gclosure gclosure) (return-value gvalue) (n-params unsigned-int)
42 (param-values pointer) (invocation-hint pointer)
43 (callback-id unsigned-int))
266ca870 44 (declare (ignore gclosure invocation-hint))
e0d2987b 45 (callback-trampoline callback-id n-params param-values return-value))
c8c48a4c 46
e0d2987b 47;; Callback function for emission hooks
56ccd5b7 48(define-callback signal-emission-hook nil
49 ((invocation-hint pointer) (n-params unsigned-int) (param-values pointer)
50 (callback-id unsigned-int))
5de2b5f6 51 (declare (ignore invocation-hint))
e0d2987b 52 (callback-trampoline callback-id n-params param-values))
53
54(defun callback-trampoline (callback-id n-params param-values &optional
55 (return-value (make-pointer 0)))
c8c48a4c 56 (let* ((return-type (unless (null-pointer-p return-value)
e378b861 57 (gvalue-type return-value)))
34f9e1d4 58 (args (loop
59 for n from 0 below n-params
832df308 60 for offset from 0 by +gvalue-size+
3005806e 61 collect (gvalue-get (sap+ param-values offset) t))))
832df308 62 (unwind-protect
63 (let ((result (apply #'invoke-callback callback-id return-type args)))
64 (when return-type
65 (gvalue-set return-value result)))
66 (loop
67 for arg in args
68 when (typep arg 'proxy)
69 do (invalidate-instance arg)))))
70
34f9e1d4 71
8755b1a5 72(defun invoke-callback (callback-id return-type &rest args)
34f9e1d4 73 (restart-case
74 (apply (find-user-data callback-id) args)
75 (continue nil :report "Return from callback function"
8755b1a5 76 (when return-type
77 (format *query-io* "Enter return value of type ~S: " return-type)
34f9e1d4 78 (force-output *query-io*)
79 (eval (read *query-io*))))
80 (re-invoke nil :report "Re-invoke callback function"
8755b1a5 81 (apply #'invoke-callback callback-id return-type args))))
c8c48a4c 82
c8c48a4c 83
e378b861 84;;;; Timeouts and idle functions
85
acd28982 86(defconstant +priority-high+ -100)
87(defconstant +priority-default+ 0)
88(defconstant +priority-high-idle+ 100)
89(defconstant +priority-default-idle+ 200)
90(defconstant +priority-low+ 300)
91
92(defbinding source-remove () boolean
93 (tag unsigned-int))
94
56ccd5b7 95(define-callback source-callback-marshal nil ((callback-id unsigned-int))
e0d2987b 96 (callback-trampoline callback-id 0 nil))
e378b861 97
98(defbinding (timeout-add "g_timeout_add_full")
acd28982 99 (interval function &optional (priority +priority-default+)) unsigned-int
e378b861 100 (priority int)
101 (interval unsigned-int)
56ccd5b7 102 (source-callback-marshal callback)
e378b861 103 ((register-callback-function function) unsigned-long)
56ccd5b7 104 (user-data-destroy-callback callback))
e378b861 105
acd28982 106(defun timeout-remove (timeout)
107 (source-remove timeout))
108
e378b861 109(defbinding (idle-add "g_idle_add_full")
acd28982 110 (function &optional (priority +priority-default-idle+)) unsigned-int
e378b861 111 (priority int)
56ccd5b7 112 (source-callback-marshal callback)
e378b861 113 ((register-callback-function function) unsigned-long)
56ccd5b7 114 (user-data-destroy-callback callback))
e378b861 115
acd28982 116(defun idle-remove (idle)
117 (source-remove idle))
e378b861 118
c8c48a4c 119
e0d2987b 120;;;; Signal information querying
c8c48a4c 121
e0d2987b 122(defbinding signal-lookup (name type) unsigned-int
c8c48a4c 123 ((signal-name-to-string name) string)
e0d2987b 124 ((find-type-number type t) type-number))
c8c48a4c 125
e0d2987b 126(defbinding signal-name () (copy-of string)
c8c48a4c 127 (signal-id unsigned-int))
128
e0d2987b 129(defbinding signal-list-ids (type) (vector unsigned-int n-ids)
130 ((find-type-number type t) type-number)
131 (n-ids unsigned-int :out))
132
133(defun signal-list-names (type)
134 (map 'list #'signal-name (signal-list-ids type)))
135
136(defun ensure-signal-id-from-type (signal-id type)
c8c48a4c 137 (etypecase signal-id
e0d2987b 138 (integer (if (signal-name signal-id)
139 signal-id
140 (error "Invalid signal id: ~D" signal-id)))
141 ((or symbol string)
142 (let ((numeric-id (signal-lookup signal-id type)))
143 (if (zerop numeric-id)
144 (error "Invalid signal name for ~S: ~D" type signal-id)
145 numeric-id)))))
146
147(defun ensure-signal-id (signal-id instance)
148 (ensure-signal-id-from-type signal-id (type-of instance)))
c8c48a4c 149
e0d2987b 150(eval-when (:compile-toplevel :load-toplevel :execute)
151 (deftype signal-flags ()
152 '(flags :run-first :run-last :run-cleanup :no-recurse
153 :detailed :action :no-hooks))
154
155 (defclass signal-query (struct)
156 ((id :allocation :alien :type unsigned-int)
157 (name :allocation :alien :type (copy-of string))
158 (type :allocation :alien :type type-number)
159 (flags :allocation :alien :type signal-flags)
160 (return-type :allocation :alien :type type-number)
161 (n-params :allocation :alien :type unsigned-int)
162 (param-types :allocation :alien :type pointer))
163 (:metaclass struct-class)))
164
165(defbinding signal-query
166 (signal-id &optional (signal-query (make-instance 'signal-query))) nil
167 (signal-id unsigned-int)
168 (signal-query signal-query :return))
169
170(defun signal-param-types (info)
171 (with-slots (n-params param-types) info
172 (map-c-vector 'list
173 #'(lambda (type-number)
174 (type-from-number type-number))
175 param-types 'type-number n-params)))
176
177
178(defun describe-signal (signal-id &optional type)
179 (let ((info (signal-query (ensure-signal-id-from-type signal-id type))))
180 (with-slots (id name type flags return-type n-params) info
181 (format t "The signal with id ~D is named '~A' and may be emitted on instances of type ~S~%~%" id name (type-from-number type t))
182 (format t "Signal handlers should return ~A and take ~A~%"
183 (cond
184 ((= return-type (find-type-number "void")) "no values")
185 ((not (type-from-number return-type)) "values of unknown type")
186 ((format nil "values of type ~S" (type-from-number return-type))))
187 (if (zerop n-params)
188 "no arguments"
189 (format nil "arguments with the following types: ~A"
190 (signal-param-types info)))))))
191
192
193;;;; Signal connecting and controlling
194
9944c385 195(defvar *overridden-signals* (make-hash-table :test 'equalp))
196
197(defbinding %signal-override-class-closure () nil
198 (signal-id unsigned-int)
199 (type-number type-number)
200 (callback-closure pointer))
201
202
203(defun signal-override-class-closure (name type function)
204 (let* ((signal-id (ensure-signal-id-from-type name type))
205 (type-number (find-type-number type t))
206 (callback-id (gethash (cons type-number signal-id) *overridden-signals*)))
207 (if callback-id
208 (update-user-data callback-id function)
209 (multiple-value-bind (callback-closure callback-id)
210 (make-callback-closure function)
211 (%signal-override-class-closure signal-id type-number callback-closure)
212 (setf
213 (gethash (cons type-number signal-id) *overridden-signals*)
214 callback-id)))))
215
216
217(defbinding %signal-chain-from-overridden () nil
218 (args pointer)
219 (return-value (or null gvalue)))
220
38049b1a 221
222(defun %call-next-handler (n-params types args return-type)
9944c385 223 (let ((params (allocate-memory (* n-params +gvalue-size+))))
224 (loop
38049b1a 225 for arg in args
9944c385 226 for type in types
227 for offset from 0 by +gvalue-size+
9944c385 228 do (gvalue-init (sap+ params offset) type arg))
229
230 (unwind-protect
231 (if return-type
232 (with-gvalue (return-value return-type)
233 (%signal-chain-from-overridden params return-value))
234 (%signal-chain-from-overridden params nil))
235 (progn
236 (loop
237 repeat n-params
238 for offset from 0 by +gvalue-size+
239 do (gvalue-unset (sap+ params offset)))
240 (deallocate-memory params)))))
241
242
243(defmacro define-signal-handler (name ((object class) &rest args) &body body)
244 (let* ((info (signal-query (ensure-signal-id-from-type name class)))
245 (types (cons class (signal-param-types info)))
246 (n-params (1+ (slot-value info 'n-params)))
247 (return-type (type-from-number (slot-value info 'return-type)))
248 (vars (loop
249 for arg in args
250 until (eq arg '&rest)
251 collect arg))
252 (rest (cadr (member '&rest args)))
38049b1a 253 (next (make-symbol "ARGS"))
254 (default (make-symbol "DEFAULT")))
9944c385 255
256 `(progn
257 (signal-override-class-closure ',name ',class
258 #'(lambda (,object ,@args)
38049b1a 259 (let ((,default (list* ,object ,@vars ,rest)))
260 (flet ((call-next-handler (&rest ,next)
9944c385 261 (%call-next-handler
38049b1a 262 ,n-params ',types (or ,next ,default) ',return-type))))
9944c385 263 ,@body)))
264 ',name)))
265
266
e0d2987b 267(defbinding %signal-stop-emission () nil
c8c48a4c 268 (instance ginstance)
e0d2987b 269 (signal-id unsigned-int)
270 (detail quark))
271
272(defvar *signal-stop-emission* nil)
273(declaim (special *signal-stop-emission*))
c8c48a4c 274
e0d2987b 275(defun signal-stop-emission ()
276 (if *signal-stop-emission*
277 (funcall *signal-stop-emission*)
278 (error "Not inside a signal handler")))
279
280
281(defbinding signal-add-emission-hook (type signal function &key (detail 0))
282 unsigned-int
283 ((ensure-signal-id-from-type signal type) unsigned-int)
284 (detail quark)
56ccd5b7 285 (signal-emission-hook callback)
e0d2987b 286 ((register-callback-function function) unsigned-int)
56ccd5b7 287 (user-data-destroy-callback callback))
e0d2987b 288
289(defbinding signal-remove-emission-hook (type signal hook-id) nil
290 ((ensure-signal-id-from-type signal type) unsigned-int)
291 (hook-id unsigned-int))
c8c48a4c 292
c8c48a4c 293
0383dd48 294(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c8c48a4c 295 (instance signal-id &key detail blocked) boolean
296 (instance ginstance)
e49e135a 297 ((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c 298 ((or detail 0) quark)
73572c12 299 (blocked boolean))
c8c48a4c 300
e0d2987b 301(defbinding %signal-connect-closure-by-id () unsigned-int
c8c48a4c 302 (instance ginstance)
e0d2987b 303 (signal-id unsigned-int)
304 (detail quark)
305 (closure pointer)
c8c48a4c 306 (after boolean))
307
0383dd48 308(defbinding signal-handler-block () nil
c8c48a4c 309 (instance ginstance)
e0d2987b 310 (handler-id unsigned-int))
c8c48a4c 311
0383dd48 312(defbinding signal-handler-unblock () nil
c8c48a4c 313 (instance ginstance)
e0d2987b 314 (handler-id unsigned-int))
c8c48a4c 315
0383dd48 316(defbinding signal-handler-disconnect () nil
c8c48a4c 317 (instance ginstance)
e0d2987b 318 (handler-id unsigned-int))
319
320(defbinding signal-handler-is-connected-p () boolean
321 (instance ginstance)
322 (handler-id unsigned-int))
c8c48a4c 323
d75a77ff 324(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
e0d2987b 325 (callback-id unsigned-int)
56ccd5b7 326 (callback callback)
327 (destroy-notify callback))
c8c48a4c 328
e0d2987b 329(defun make-callback-closure (function)
330 (let ((callback-id (register-callback-function function)))
331 (values
56ccd5b7 332 (callback-closure-new callback-id closure-marshal user-data-destroy-callback)
e0d2987b 333 callback-id)))
334
cd9b9e8b 335(defgeneric compute-signal-function (gobject signal function object))
65670fe5 336
cd9b9e8b 337(defmethod compute-signal-function ((gobject gobject) signal function object)
338 (declare (ignore signal))
e0d2987b 339 (cond
cd9b9e8b 340 ((or (eq object t) (eq object gobject)) function)
341 ((not object)
e0d2987b 342 #'(lambda (&rest args) (apply function (rest args))))
343 (t
cd9b9e8b 344 #'(lambda (&rest args) (apply function object (rest args))))))
345
346
347(defgeneric compute-signal-id (gobject signal))
348
349(defmethod compute-signal-id ((gobject gobject) signal)
350 (ensure-signal-id signal gobject))
351
352
353(defgeneric signal-connect (gobject signal function &key detail after object remove))
354
355(defmethod signal-connect :around ((gobject gobject) signal function &rest args)
356 (declare (ignore gobject signal args))
357 (when function
358 (call-next-method)))
e0d2987b 359
65670fe5 360
e0d2987b 361(defmethod signal-connect ((gobject gobject) signal function
cd9b9e8b 362 &key detail after object remove)
e0d2987b 363"Connects a callback function to a signal for a particular object. If
364:OBJECT is T, the object connected to is passed as the first argument
365to the callback function, or if :OBJECT is any other non NIL value, it
366is passed as the first argument instead. If :AFTER is non NIL, the
367handler will be called after the default handler for the signal. If
368:REMOVE is non NIL, the handler will be removed after beeing invoked
369once."
cd9b9e8b 370(let* ((signal-id (compute-signal-id gobject signal))
371 (detail-quark (if detail (quark-intern detail) 0))
372 (signal-stop-emission
373 #'(lambda ()
374 (%signal-stop-emission gobject signal-id detail-quark)))
375 (callback (compute-signal-function gobject signal function object))
376 (wrapper #'(lambda (&rest args)
377 (let ((*signal-stop-emission* signal-stop-emission))
378 (apply callback args)))))
e0d2987b 379 (multiple-value-bind (closure-id callback-id)
380 (make-callback-closure wrapper)
381 (let ((handler-id (%signal-connect-closure-by-id
cd9b9e8b 382 gobject signal-id detail-quark closure-id after)))
e0d2987b 383 (when remove
384 (update-user-data callback-id
385 #'(lambda (&rest args)
386 (unwind-protect
387 (let ((*signal-stop-emission* signal-stop-emission))
388 (apply callback args))
389 (signal-handler-disconnect gobject handler-id)))))
cd9b9e8b 390 handler-id))))
e0d2987b 391
392
393;;;; Signal emission
394
395(defbinding %signal-emitv () nil
396 (gvalues pointer)
397 (signal-id unsigned-int)
398 (detail quark)
399 (return-value gvalue))
400
401(defvar *signal-emit-functions* (make-hash-table))
402
403(defun create-signal-emit-function (signal-id)
404 (let ((info (signal-query signal-id)))
405 (let* ((type (type-from-number (slot-value info 'type)))
406 (param-types (cons type (signal-param-types info)))
407 (return-type (type-from-number (slot-value info 'return-type)))
408 (n-params (1+ (slot-value info 'n-params)))
409 (params (allocate-memory (* n-params +gvalue-size+))))
410 #'(lambda (detail object &rest args)
411 (unless (= (length args) (1- n-params))
412 (error "Invalid number of arguments: ~A" (+ 2 (length args))))
413 (unwind-protect
414 (loop
415 for arg in (cons object args)
416 for type in param-types
417 as tmp = params then (sap+ tmp +gvalue-size+)
418 do (gvalue-init tmp type arg)
419 finally
420 (if return-type
421 (return
422 (with-gvalue (return-value)
423 (%signal-emitv params signal-id detail return-value)))
424 (%signal-emitv params signal-id detail (make-pointer 0))))
425 (loop
426 repeat n-params
427 as tmp = params then (sap+ tmp +gvalue-size+)
428 while (gvalue-p tmp)
429 do (gvalue-unset tmp)))))))
430
431(defun signal-emit-with-detail (object signal detail &rest args)
432 (let* ((signal-id (ensure-signal-id signal object))
433 (function (or
434 (gethash signal-id *signal-emit-functions*)
435 (setf
436 (gethash signal-id *signal-emit-functions*)
437 (create-signal-emit-function signal-id)))))
438 (apply function detail object args)))
439
440(defun signal-emit (object signal &rest args)
441 (apply #'signal-emit-with-detail object signal 0 args))
442
c0f178d0 443
fd1e4a39 444;;;; Convenient macros
445
56ccd5b7 446(defmacro define-callback-marshal (name return-type args &key (callback-id :last))
447 (let* ((ignore ())
448 (params ())
449 (names (loop
450 for arg in args
451 collect (if (or
452 (eq arg :ignore)
453 (and (consp arg) (eq (first arg) :ignore)))
454 (let ((name (gensym "IGNORE")))
455 (push name ignore)
456 name)
457 (let ((name (if (atom arg)
458 (gensym (string arg))
459 (first arg))))
460 (push name params)
461 name))))
462 (types (loop
463 for arg in args
464 collect (cond
465 ((eq arg :ignore) 'pointer)
466 ((atom arg) arg)
467 (t (second arg))))))
468 `(define-callback ,name ,return-type
469 ,(ecase callback-id
470 (:first `((callback-id unsigned-int) ,@(mapcar #'list names types)))
471 (:last `(,@(mapcar #'list names types) (callback-id unsigned-int))))
472 (declare (ignore ,@ignore))
248f4dd7 473 (invoke-callback callback-id ',return-type ,@(nreverse params)))))
fd1e4a39 474
475(defmacro with-callback-function ((id function) &body body)
476 `(let ((,id (register-callback-function ,function)))
477 (unwind-protect
478 (progn ,@body)
479 (destroy-user-data ,id))))
56ccd5b7 480
481;; For backward compatibility
482(defmacro def-callback-marshal (name (return-type &rest args))
483 `(define-callback-marshal ,name ,return-type ,args))