chiark / gitweb /
Removed callback.c from the system
[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
e7225d0f 23;; $Id: gcallback.lisp,v 1.36 2006-07-14 10:51:07 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
e7225d0f 39;; Callback marshaller for regular signal handlers
40(define-callback signal-handler-marshal nil
56ccd5b7 41 ((gclosure gclosure) (return-value gvalue) (n-params unsigned-int)
42 (param-values pointer) (invocation-hint pointer)
e7225d0f 43 (callback-id unsigned-long))
266ca870 44 (declare (ignore gclosure invocation-hint))
e7225d0f 45 (callback-trampoline #'invoke-signal-handler callback-id n-params param-values return-value))
c8c48a4c 46
e7225d0f 47;; Callback marshaller for class handlers
48(define-callback class-handler-marshal nil
49 ((gclosure gclosure) (return-value gvalue) (n-params unsigned-int)
50 (param-values pointer) (invocation-hint pointer)
51 (callback-id unsigned-long))
52 (declare (ignore gclosure invocation-hint))
53 (callback-trampoline #'invoke-callback callback-id n-params param-values return-value))
54
55;; Callback marshaller for emission hooks
56(define-callback emission-hook-marshal nil
56ccd5b7 57 ((invocation-hint pointer) (n-params unsigned-int) (param-values pointer)
e7225d0f 58 (callback-id unsigned-long))
5de2b5f6 59 (declare (ignore invocation-hint))
e7225d0f 60 (callback-trampoline #'invoke-callback callback-id n-params param-values))
e0d2987b 61
e7225d0f 62(defun callback-trampoline (restart-wrapper callback-id n-params param-values
63 &optional (return-value (make-pointer 0)))
c8c48a4c 64 (let* ((return-type (unless (null-pointer-p return-value)
e378b861 65 (gvalue-type return-value)))
34f9e1d4 66 (args (loop
67 for n from 0 below n-params
832df308 68 for offset from 0 by +gvalue-size+
77a843ca 69 collect (gvalue-peek (pointer+ param-values offset)))))
832df308 70 (unwind-protect
e7225d0f 71 (multiple-value-bind (result aborted-p)
72 (apply restart-wrapper callback-id nil args)
73 (when (and return-type (not aborted-p))
832df308 74 (gvalue-set return-value result)))
77a843ca 75 ;; TODO: this should be made more general, by adding a type
e7225d0f 76 ;; method to return invalidating functions.
832df308 77 (loop
78 for arg in args
77a843ca 79 when (typep arg 'struct)
832df308 80 do (invalidate-instance arg)))))
81
e7225d0f 82(defun invoke-signal-handler (callback-id return-type &rest args)
83 (declare (ignore return-type))
84 (let* ((instance (first args))
85 (handler-id (signal-handler-find instance '(:data)
86 0 0 nil nil callback-id)))
87 (signal-handler-block instance handler-id)
88 (unwind-protect
89 (restart-case (apply #'invoke-callback callback-id nil args)
90 (abort () :report "Disconnect and exit signal handler"
91 (when (signal-handler-is-connected-p instance handler-id)
92 (signal-handler-disconnect instance handler-id))
93 (values nil t))))
94 (when (signal-handler-is-connected-p instance handler-id)
95 (signal-handler-unblock instance handler-id))))
34f9e1d4 96
8755b1a5 97(defun invoke-callback (callback-id return-type &rest args)
e7225d0f 98 (restart-case (apply (find-user-data callback-id) args)
34f9e1d4 99 (continue nil :report "Return from callback function"
e7225d0f 100 (cond
101 (return-type
102 (format *query-io* "Enter return value of type ~S: " return-type)
103 (force-output *query-io*)
104 (eval (read *query-io*)))
105 (t (values nil t))))
34f9e1d4 106 (re-invoke nil :report "Re-invoke callback function"
e7225d0f 107 (apply #'invoke-callback callback-id return-type args))))
c8c48a4c 108
c8c48a4c 109
e378b861 110;;;; Timeouts and idle functions
111
acd28982 112(defconstant +priority-high+ -100)
113(defconstant +priority-default+ 0)
114(defconstant +priority-high-idle+ 100)
115(defconstant +priority-default-idle+ 200)
116(defconstant +priority-low+ 300)
117
118(defbinding source-remove () boolean
119 (tag unsigned-int))
120
56ccd5b7 121(define-callback source-callback-marshal nil ((callback-id unsigned-int))
e0d2987b 122 (callback-trampoline callback-id 0 nil))
e378b861 123
124(defbinding (timeout-add "g_timeout_add_full")
acd28982 125 (interval function &optional (priority +priority-default+)) unsigned-int
e378b861 126 (priority int)
127 (interval unsigned-int)
56ccd5b7 128 (source-callback-marshal callback)
e378b861 129 ((register-callback-function function) unsigned-long)
56ccd5b7 130 (user-data-destroy-callback callback))
e378b861 131
acd28982 132(defun timeout-remove (timeout)
133 (source-remove timeout))
134
e378b861 135(defbinding (idle-add "g_idle_add_full")
acd28982 136 (function &optional (priority +priority-default-idle+)) unsigned-int
e378b861 137 (priority int)
56ccd5b7 138 (source-callback-marshal callback)
e378b861 139 ((register-callback-function function) unsigned-long)
56ccd5b7 140 (user-data-destroy-callback callback))
e378b861 141
acd28982 142(defun idle-remove (idle)
143 (source-remove idle))
e378b861 144
c8c48a4c 145
e0d2987b 146;;;; Signal information querying
c8c48a4c 147
e0d2987b 148(defbinding signal-lookup (name type) unsigned-int
c8c48a4c 149 ((signal-name-to-string name) string)
e0d2987b 150 ((find-type-number type t) type-number))
c8c48a4c 151
e0d2987b 152(defbinding signal-name () (copy-of string)
c8c48a4c 153 (signal-id unsigned-int))
154
e0d2987b 155(defbinding signal-list-ids (type) (vector unsigned-int n-ids)
156 ((find-type-number type t) type-number)
157 (n-ids unsigned-int :out))
158
159(defun signal-list-names (type)
160 (map 'list #'signal-name (signal-list-ids type)))
161
162(defun ensure-signal-id-from-type (signal-id type)
c8c48a4c 163 (etypecase signal-id
e0d2987b 164 (integer (if (signal-name signal-id)
165 signal-id
166 (error "Invalid signal id: ~D" signal-id)))
167 ((or symbol string)
168 (let ((numeric-id (signal-lookup signal-id type)))
169 (if (zerop numeric-id)
170 (error "Invalid signal name for ~S: ~D" type signal-id)
171 numeric-id)))))
172
173(defun ensure-signal-id (signal-id instance)
174 (ensure-signal-id-from-type signal-id (type-of instance)))
c8c48a4c 175
e0d2987b 176(eval-when (:compile-toplevel :load-toplevel :execute)
177 (deftype signal-flags ()
178 '(flags :run-first :run-last :run-cleanup :no-recurse
179 :detailed :action :no-hooks))
180
e7225d0f 181 (define-flags-type signal-match-type
182 :id :detail :closure :func :data :unblocked)
183
e0d2987b 184 (defclass signal-query (struct)
185 ((id :allocation :alien :type unsigned-int)
186 (name :allocation :alien :type (copy-of string))
187 (type :allocation :alien :type type-number)
188 (flags :allocation :alien :type signal-flags)
189 (return-type :allocation :alien :type type-number)
190 (n-params :allocation :alien :type unsigned-int)
191 (param-types :allocation :alien :type pointer))
192 (:metaclass struct-class)))
193
194(defbinding signal-query
195 (signal-id &optional (signal-query (make-instance 'signal-query))) nil
196 (signal-id unsigned-int)
77a843ca 197 (signal-query signal-query :in/return))
e0d2987b 198
199(defun signal-param-types (info)
200 (with-slots (n-params param-types) info
201 (map-c-vector 'list
202 #'(lambda (type-number)
203 (type-from-number type-number))
204 param-types 'type-number n-params)))
205
206
207(defun describe-signal (signal-id &optional type)
208 (let ((info (signal-query (ensure-signal-id-from-type signal-id type))))
209 (with-slots (id name type flags return-type n-params) info
210 (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))
211 (format t "Signal handlers should return ~A and take ~A~%"
212 (cond
213 ((= return-type (find-type-number "void")) "no values")
214 ((not (type-from-number return-type)) "values of unknown type")
215 ((format nil "values of type ~S" (type-from-number return-type))))
216 (if (zerop n-params)
217 "no arguments"
218 (format nil "arguments with the following types: ~A"
219 (signal-param-types info)))))))
220
221
222;;;; Signal connecting and controlling
223
9944c385 224(defvar *overridden-signals* (make-hash-table :test 'equalp))
225
226(defbinding %signal-override-class-closure () nil
227 (signal-id unsigned-int)
228 (type-number type-number)
229 (callback-closure pointer))
230
231
232(defun signal-override-class-closure (name type function)
233 (let* ((signal-id (ensure-signal-id-from-type name type))
234 (type-number (find-type-number type t))
235 (callback-id (gethash (cons type-number signal-id) *overridden-signals*)))
236 (if callback-id
237 (update-user-data callback-id function)
238 (multiple-value-bind (callback-closure callback-id)
e7225d0f 239 (make-callback-closure function class-handler-marshal)
9944c385 240 (%signal-override-class-closure signal-id type-number callback-closure)
241 (setf
242 (gethash (cons type-number signal-id) *overridden-signals*)
243 callback-id)))))
244
245
246(defbinding %signal-chain-from-overridden () nil
247 (args pointer)
248 (return-value (or null gvalue)))
249
38049b1a 250
251(defun %call-next-handler (n-params types args return-type)
9944c385 252 (let ((params (allocate-memory (* n-params +gvalue-size+))))
253 (loop
38049b1a 254 for arg in args
9944c385 255 for type in types
256 for offset from 0 by +gvalue-size+
77a843ca 257 do (gvalue-init (pointer+ params offset) type arg))
9944c385 258
259 (unwind-protect
260 (if return-type
261 (with-gvalue (return-value return-type)
262 (%signal-chain-from-overridden params return-value))
263 (%signal-chain-from-overridden params nil))
264 (progn
265 (loop
266 repeat n-params
267 for offset from 0 by +gvalue-size+
77a843ca 268 do (gvalue-unset (pointer+ params offset)))
9944c385 269 (deallocate-memory params)))))
270
271
272(defmacro define-signal-handler (name ((object class) &rest args) &body body)
273 (let* ((info (signal-query (ensure-signal-id-from-type name class)))
274 (types (cons class (signal-param-types info)))
275 (n-params (1+ (slot-value info 'n-params)))
276 (return-type (type-from-number (slot-value info 'return-type)))
277 (vars (loop
278 for arg in args
279 until (eq arg '&rest)
280 collect arg))
281 (rest (cadr (member '&rest args)))
38049b1a 282 (next (make-symbol "ARGS"))
283 (default (make-symbol "DEFAULT")))
9944c385 284
285 `(progn
286 (signal-override-class-closure ',name ',class
287 #'(lambda (,object ,@args)
38049b1a 288 (let ((,default (list* ,object ,@vars ,rest)))
289 (flet ((call-next-handler (&rest ,next)
9944c385 290 (%call-next-handler
e1fcda22 291 ,n-params ',types (or ,next ,default) ',return-type)))
292 ,@body))))
9944c385 293 ',name)))
294
295
e0d2987b 296(defbinding %signal-stop-emission () nil
c8c48a4c 297 (instance ginstance)
e0d2987b 298 (signal-id unsigned-int)
299 (detail quark))
300
301(defvar *signal-stop-emission* nil)
302(declaim (special *signal-stop-emission*))
c8c48a4c 303
e0d2987b 304(defun signal-stop-emission ()
305 (if *signal-stop-emission*
306 (funcall *signal-stop-emission*)
307 (error "Not inside a signal handler")))
308
309
310(defbinding signal-add-emission-hook (type signal function &key (detail 0))
e7225d0f 311 unsigned-long
e0d2987b 312 ((ensure-signal-id-from-type signal type) unsigned-int)
313 (detail quark)
e7225d0f 314 (emission-hook-marshal callback)
e0d2987b 315 ((register-callback-function function) unsigned-int)
56ccd5b7 316 (user-data-destroy-callback callback))
e0d2987b 317
318(defbinding signal-remove-emission-hook (type signal hook-id) nil
319 ((ensure-signal-id-from-type signal type) unsigned-int)
e7225d0f 320 (hook-id unsigned-long))
c8c48a4c 321
c8c48a4c 322
0383dd48 323(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c8c48a4c 324 (instance signal-id &key detail blocked) boolean
325 (instance ginstance)
e49e135a 326 ((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c 327 ((or detail 0) quark)
73572c12 328 (blocked boolean))
c8c48a4c 329
e7225d0f 330(defbinding %signal-connect-closure-by-id () unsigned-long
c8c48a4c 331 (instance ginstance)
e0d2987b 332 (signal-id unsigned-int)
333 (detail quark)
334 (closure pointer)
c8c48a4c 335 (after boolean))
336
0383dd48 337(defbinding signal-handler-block () nil
c8c48a4c 338 (instance ginstance)
e7225d0f 339 (handler-id unsigned-long))
c8c48a4c 340
0383dd48 341(defbinding signal-handler-unblock () nil
c8c48a4c 342 (instance ginstance)
e7225d0f 343 (handler-id unsigned-long))
344
345;; Internal
346(defbinding signal-handler-find () unsigned-long
347 (instance gobject)
348 (mask signal-match-type)
349 (signal-id unsigned-int)
350 (detail quark)
351 (closure (or null pointer))
352 (func (or null pointer))
353 (data unsigned-long))
c8c48a4c 354
0383dd48 355(defbinding signal-handler-disconnect () nil
c8c48a4c 356 (instance ginstance)
e7225d0f 357 (handler-id unsigned-long))
e0d2987b 358
359(defbinding signal-handler-is-connected-p () boolean
360 (instance ginstance)
e7225d0f 361 (handler-id unsigned-long))
c8c48a4c 362
d75a77ff 363(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
e0d2987b 364 (callback-id unsigned-int)
56ccd5b7 365 (callback callback)
366 (destroy-notify callback))
c8c48a4c 367
e7225d0f 368(defun make-callback-closure (function marshaller)
e0d2987b 369 (let ((callback-id (register-callback-function function)))
370 (values
e7225d0f 371 (callback-closure-new callback-id marshaller user-data-destroy-callback)
e0d2987b 372 callback-id)))
373
cd9b9e8b 374(defgeneric compute-signal-function (gobject signal function object))
65670fe5 375
cd9b9e8b 376(defmethod compute-signal-function ((gobject gobject) signal function object)
377 (declare (ignore signal))
e0d2987b 378 (cond
cd9b9e8b 379 ((or (eq object t) (eq object gobject)) function)
380 ((not object)
e0d2987b 381 #'(lambda (&rest args) (apply function (rest args))))
382 (t
cd9b9e8b 383 #'(lambda (&rest args) (apply function object (rest args))))))
384
385
386(defgeneric compute-signal-id (gobject signal))
387
388(defmethod compute-signal-id ((gobject gobject) signal)
389 (ensure-signal-id signal gobject))
390
391
392(defgeneric signal-connect (gobject signal function &key detail after object remove))
393
394(defmethod signal-connect :around ((gobject gobject) signal function &rest args)
395 (declare (ignore gobject signal args))
396 (when function
397 (call-next-method)))
e0d2987b 398
65670fe5 399
e0d2987b 400(defmethod signal-connect ((gobject gobject) signal function
cd9b9e8b 401 &key detail after object remove)
e0d2987b 402"Connects a callback function to a signal for a particular object. If
403:OBJECT is T, the object connected to is passed as the first argument
404to the callback function, or if :OBJECT is any other non NIL value, it
405is passed as the first argument instead. If :AFTER is non NIL, the
406handler will be called after the default handler for the signal. If
407:REMOVE is non NIL, the handler will be removed after beeing invoked
408once."
cd9b9e8b 409(let* ((signal-id (compute-signal-id gobject signal))
410 (detail-quark (if detail (quark-intern detail) 0))
411 (signal-stop-emission
412 #'(lambda ()
413 (%signal-stop-emission gobject signal-id detail-quark)))
414 (callback (compute-signal-function gobject signal function object))
415 (wrapper #'(lambda (&rest args)
416 (let ((*signal-stop-emission* signal-stop-emission))
417 (apply callback args)))))
e0d2987b 418 (multiple-value-bind (closure-id callback-id)
e7225d0f 419 (make-callback-closure wrapper signal-handler-marshal)
e0d2987b 420 (let ((handler-id (%signal-connect-closure-by-id
cd9b9e8b 421 gobject signal-id detail-quark closure-id after)))
e0d2987b 422 (when remove
423 (update-user-data callback-id
424 #'(lambda (&rest args)
425 (unwind-protect
426 (let ((*signal-stop-emission* signal-stop-emission))
427 (apply callback args))
e7225d0f 428 (when (signal-handler-is-connected-p gobject handler-id)
429 (signal-handler-disconnect gobject handler-id))))))
cd9b9e8b 430 handler-id))))
e0d2987b 431
432
433;;;; Signal emission
434
435(defbinding %signal-emitv () nil
436 (gvalues pointer)
437 (signal-id unsigned-int)
438 (detail quark)
439 (return-value gvalue))
440
441(defvar *signal-emit-functions* (make-hash-table))
442
443(defun create-signal-emit-function (signal-id)
444 (let ((info (signal-query signal-id)))
445 (let* ((type (type-from-number (slot-value info 'type)))
446 (param-types (cons type (signal-param-types info)))
447 (return-type (type-from-number (slot-value info 'return-type)))
448 (n-params (1+ (slot-value info 'n-params)))
449 (params (allocate-memory (* n-params +gvalue-size+))))
450 #'(lambda (detail object &rest args)
451 (unless (= (length args) (1- n-params))
452 (error "Invalid number of arguments: ~A" (+ 2 (length args))))
453 (unwind-protect
454 (loop
455 for arg in (cons object args)
456 for type in param-types
77a843ca 457 as tmp = params then (pointer+ tmp +gvalue-size+)
e0d2987b 458 do (gvalue-init tmp type arg)
459 finally
460 (if return-type
461 (return
462 (with-gvalue (return-value)
463 (%signal-emitv params signal-id detail return-value)))
464 (%signal-emitv params signal-id detail (make-pointer 0))))
465 (loop
466 repeat n-params
77a843ca 467 as tmp = params then (pointer+ tmp +gvalue-size+)
e0d2987b 468 while (gvalue-p tmp)
469 do (gvalue-unset tmp)))))))
470
471(defun signal-emit-with-detail (object signal detail &rest args)
472 (let* ((signal-id (ensure-signal-id signal object))
473 (function (or
474 (gethash signal-id *signal-emit-functions*)
475 (setf
476 (gethash signal-id *signal-emit-functions*)
477 (create-signal-emit-function signal-id)))))
478 (apply function detail object args)))
479
480(defun signal-emit (object signal &rest args)
481 (apply #'signal-emit-with-detail object signal 0 args))
482
c0f178d0 483
fd1e4a39 484;;;; Convenient macros
485
56ccd5b7 486(defmacro define-callback-marshal (name return-type args &key (callback-id :last))
487 (let* ((ignore ())
488 (params ())
489 (names (loop
490 for arg in args
491 collect (if (or
492 (eq arg :ignore)
493 (and (consp arg) (eq (first arg) :ignore)))
494 (let ((name (gensym "IGNORE")))
495 (push name ignore)
496 name)
497 (let ((name (if (atom arg)
498 (gensym (string arg))
499 (first arg))))
500 (push name params)
501 name))))
502 (types (loop
503 for arg in args
504 collect (cond
505 ((eq arg :ignore) 'pointer)
506 ((atom arg) arg)
507 (t (second arg))))))
508 `(define-callback ,name ,return-type
509 ,(ecase callback-id
510 (:first `((callback-id unsigned-int) ,@(mapcar #'list names types)))
511 (:last `(,@(mapcar #'list names types) (callback-id unsigned-int))))
512 (declare (ignore ,@ignore))
248f4dd7 513 (invoke-callback callback-id ',return-type ,@(nreverse params)))))
fd1e4a39 514
515(defmacro with-callback-function ((id function) &body body)
516 `(let ((,id (register-callback-function ,function)))
517 (unwind-protect
518 (progn ,@body)
519 (destroy-user-data ,id))))