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