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