Added declaration to get rid of a couple of warnings.
[clg] / glib / gcallback.lisp
CommitLineData
c9819f3e 1;; Common Lisp bindings for GTK+ v2.0
2;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
3;;
4;; This library is free software; you can redistribute it and/or
5;; modify it under the terms of the GNU Lesser General Public
6;; License as published by the Free Software Foundation; either
7;; version 2 of the License, or (at your option) any later version.
8;;
9;; This library is distributed in the hope that it will be useful,
10;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12;; Lesser General Public License for more details.
13;;
14;; You should have received a copy of the GNU Lesser General Public
15;; License along with this library; if not, write to the Free Software
16;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17
08d14e5e 18;; $Id: gcallback.lisp,v 1.23 2005/03/06 17:18:00 espen Exp $
c9819f3e 19
20(in-package "GLIB")
21
22(use-prefix "g")
23
24
3b8e5eb0 25;;;; Callback invokation
c9819f3e 26
60cfb912 27(defun register-callback-function (function)
28 (check-type function (or null symbol function))
29 (register-user-data function))
c9819f3e 30
3b8e5eb0 31;; Callback marshal for regular signal handlers
32(defcallback closure-marshal (nil
33 (gclosure pointer)
34 (return-value gvalue)
35 (n-params unsigned-int)
36 (param-values pointer)
37 (invocation-hint pointer)
38 (callback-id unsigned-int))
08d14e5e 39 (declare (ignore gclosure invocation-hint))
3b8e5eb0 40 (callback-trampoline callback-id n-params param-values return-value))
c9819f3e 41
3b8e5eb0 42;; Callback function for emission hooks
43(defcallback signal-emission-hook (nil
44 (invocation-hint pointer)
45 (n-params unsigned-int)
46 (param-values pointer)
47 (callback-id unsigned-int))
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
56 collect (gvalue-get (sap+ param-values (* n +gvalue-size+))))))
57 (let ((result (apply #'invoke-callback callback-id return-type args)))
58 (when return-type
59 (gvalue-set return-value result)))))
60
7bde5a67 61(defun invoke-callback (callback-id return-type &rest args)
831668e8 62 (restart-case
63 (apply (find-user-data callback-id) args)
64 (continue nil :report "Return from callback function"
7bde5a67 65 (when return-type
66 (format *query-io* "Enter return value of type ~S: " return-type)
831668e8 67 (force-output *query-io*)
68 (eval (read *query-io*))))
69 (re-invoke nil :report "Re-invoke callback function"
7bde5a67 70 (apply #'invoke-callback callback-id return-type args))))
c9819f3e 71
c9819f3e 72
60cfb912 73;;;; Timeouts and idle functions
74
0f2fb864 75(defconstant +priority-high+ -100)
76(defconstant +priority-default+ 0)
77(defconstant +priority-high-idle+ 100)
78(defconstant +priority-default-idle+ 200)
79(defconstant +priority-low+ 300)
80
81(defbinding source-remove () boolean
82 (tag unsigned-int))
83
7bde5a67 84(defcallback source-callback-marshal (nil (callback-id unsigned-int))
3b8e5eb0 85 (callback-trampoline callback-id 0 nil))
60cfb912 86
87(defbinding (timeout-add "g_timeout_add_full")
0f2fb864 88 (interval function &optional (priority +priority-default+)) unsigned-int
60cfb912 89 (priority int)
90 (interval unsigned-int)
0f2fb864 91 ((callback source-callback-marshal) pointer)
60cfb912 92 ((register-callback-function function) unsigned-long)
3d36c5d6 93 ((callback user-data-destroy-func) pointer))
60cfb912 94
0f2fb864 95(defun timeout-remove (timeout)
96 (source-remove timeout))
97
60cfb912 98(defbinding (idle-add "g_idle_add_full")
0f2fb864 99 (function &optional (priority +priority-default-idle+)) unsigned-int
60cfb912 100 (priority int)
0f2fb864 101 ((callback source-callback-marshal) pointer)
60cfb912 102 ((register-callback-function function) unsigned-long)
3d36c5d6 103 ((callback user-data-destroy-func) pointer))
60cfb912 104
0f2fb864 105(defun idle-remove (idle)
106 (source-remove idle))
60cfb912 107
c9819f3e 108
3b8e5eb0 109;;;; Signal information querying
c9819f3e 110
3b8e5eb0 111(defbinding signal-lookup (name type) unsigned-int
c9819f3e 112 ((signal-name-to-string name) string)
3b8e5eb0 113 ((find-type-number type t) type-number))
c9819f3e 114
3b8e5eb0 115(defbinding signal-name () (copy-of string)
c9819f3e 116 (signal-id unsigned-int))
117
3b8e5eb0 118(defbinding signal-list-ids (type) (vector unsigned-int n-ids)
119 ((find-type-number type t) type-number)
120 (n-ids unsigned-int :out))
121
122(defun signal-list-names (type)
123 (map 'list #'signal-name (signal-list-ids type)))
124
125(defun ensure-signal-id-from-type (signal-id type)
c9819f3e 126 (etypecase signal-id
3b8e5eb0 127 (integer (if (signal-name signal-id)
128 signal-id
129 (error "Invalid signal id: ~D" signal-id)))
130 ((or symbol string)
131 (let ((numeric-id (signal-lookup signal-id type)))
132 (if (zerop numeric-id)
133 (error "Invalid signal name for ~S: ~D" type signal-id)
134 numeric-id)))))
135
136(defun ensure-signal-id (signal-id instance)
137 (ensure-signal-id-from-type signal-id (type-of instance)))
c9819f3e 138
3b8e5eb0 139(eval-when (:compile-toplevel :load-toplevel :execute)
140 (deftype signal-flags ()
141 '(flags :run-first :run-last :run-cleanup :no-recurse
142 :detailed :action :no-hooks))
143
144 (defclass signal-query (struct)
145 ((id :allocation :alien :type unsigned-int)
146 (name :allocation :alien :type (copy-of string))
147 (type :allocation :alien :type type-number)
148 (flags :allocation :alien :type signal-flags)
149 (return-type :allocation :alien :type type-number)
150 (n-params :allocation :alien :type unsigned-int)
151 (param-types :allocation :alien :type pointer))
152 (:metaclass struct-class)))
153
154(defbinding signal-query
155 (signal-id &optional (signal-query (make-instance 'signal-query))) nil
156 (signal-id unsigned-int)
157 (signal-query signal-query :return))
158
159(defun signal-param-types (info)
160 (with-slots (n-params param-types) info
161 (map-c-vector 'list
162 #'(lambda (type-number)
163 (type-from-number type-number))
164 param-types 'type-number n-params)))
165
166
167(defun describe-signal (signal-id &optional type)
168 (let ((info (signal-query (ensure-signal-id-from-type signal-id type))))
169 (with-slots (id name type flags return-type n-params) info
170 (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))
171 (format t "Signal handlers should return ~A and take ~A~%"
172 (cond
173 ((= return-type (find-type-number "void")) "no values")
174 ((not (type-from-number return-type)) "values of unknown type")
175 ((format nil "values of type ~S" (type-from-number return-type))))
176 (if (zerop n-params)
177 "no arguments"
178 (format nil "arguments with the following types: ~A"
179 (signal-param-types info)))))))
180
181
182;;;; Signal connecting and controlling
183
184(defbinding %signal-stop-emission () nil
c9819f3e 185 (instance ginstance)
3b8e5eb0 186 (signal-id unsigned-int)
187 (detail quark))
188
189(defvar *signal-stop-emission* nil)
190(declaim (special *signal-stop-emission*))
c9819f3e 191
3b8e5eb0 192(defun signal-stop-emission ()
193 (if *signal-stop-emission*
194 (funcall *signal-stop-emission*)
195 (error "Not inside a signal handler")))
196
197
198(defbinding signal-add-emission-hook (type signal function &key (detail 0))
199 unsigned-int
200 ((ensure-signal-id-from-type signal type) unsigned-int)
201 (detail quark)
202 ((callback signal-emission-hook) pointer)
203 ((register-callback-function function) unsigned-int)
3d36c5d6 204 ((callback user-data-destroy-func) pointer))
3b8e5eb0 205
206(defbinding signal-remove-emission-hook (type signal hook-id) nil
207 ((ensure-signal-id-from-type signal type) unsigned-int)
208 (hook-id unsigned-int))
c9819f3e 209
c9819f3e 210
3f4249c7 211(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c9819f3e 212 (instance signal-id &key detail blocked) boolean
213 (instance ginstance)
7eec806d 214 ((ensure-signal-id signal-id instance) unsigned-int)
c9819f3e 215 ((or detail 0) quark)
3d36c5d6 216 (blocked boolean))
c9819f3e 217
3b8e5eb0 218(defbinding %signal-connect-closure-by-id () unsigned-int
c9819f3e 219 (instance ginstance)
3b8e5eb0 220 (signal-id unsigned-int)
221 (detail quark)
222 (closure pointer)
c9819f3e 223 (after boolean))
224
3f4249c7 225(defbinding signal-handler-block () nil
c9819f3e 226 (instance ginstance)
3b8e5eb0 227 (handler-id unsigned-int))
c9819f3e 228
3f4249c7 229(defbinding signal-handler-unblock () nil
c9819f3e 230 (instance ginstance)
3b8e5eb0 231 (handler-id unsigned-int))
c9819f3e 232
3f4249c7 233(defbinding signal-handler-disconnect () nil
c9819f3e 234 (instance ginstance)
3b8e5eb0 235 (handler-id unsigned-int))
236
237(defbinding signal-handler-is-connected-p () boolean
238 (instance ginstance)
239 (handler-id unsigned-int))
c9819f3e 240
bde4e068 241(deftype gclosure () 'pointer)
242
243(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
3b8e5eb0 244 (callback-id unsigned-int)
245 (callback pointer)
246 (destroy-notify pointer))
c9819f3e 247
3b8e5eb0 248(defun make-callback-closure (function)
249 (let ((callback-id (register-callback-function function)))
250 (values
251 (callback-closure-new
252 callback-id (callback closure-marshal)
3d36c5d6 253 (callback user-data-destroy-func))
3b8e5eb0 254 callback-id)))
255
54ea42fe 256(defgeneric compute-signal-function (gobject signal function object))
a6e13fb0 257
54ea42fe 258(defmethod compute-signal-function ((gobject gobject) signal function object)
259 (declare (ignore signal))
3b8e5eb0 260 (cond
54ea42fe 261 ((or (eq object t) (eq object gobject)) function)
262 ((not object)
3b8e5eb0 263 #'(lambda (&rest args) (apply function (rest args))))
264 (t
54ea42fe 265 #'(lambda (&rest args) (apply function object (rest args))))))
266
267
268(defgeneric compute-signal-id (gobject signal))
269
270(defmethod compute-signal-id ((gobject gobject) signal)
271 (ensure-signal-id signal gobject))
272
273
274(defgeneric signal-connect (gobject signal function &key detail after object remove))
275
276(defmethod signal-connect :around ((gobject gobject) signal function &rest args)
277 (declare (ignore gobject signal args))
278 (when function
279 (call-next-method)))
3b8e5eb0 280
a6e13fb0 281
3b8e5eb0 282(defmethod signal-connect ((gobject gobject) signal function
54ea42fe 283 &key detail after object remove)
3b8e5eb0 284"Connects a callback function to a signal for a particular object. If
285:OBJECT is T, the object connected to is passed as the first argument
286to the callback function, or if :OBJECT is any other non NIL value, it
287is passed as the first argument instead. If :AFTER is non NIL, the
288handler will be called after the default handler for the signal. If
289:REMOVE is non NIL, the handler will be removed after beeing invoked
290once."
54ea42fe 291(let* ((signal-id (compute-signal-id gobject signal))
292 (detail-quark (if detail (quark-intern detail) 0))
293 (signal-stop-emission
294 #'(lambda ()
295 (%signal-stop-emission gobject signal-id detail-quark)))
296 (callback (compute-signal-function gobject signal function object))
297 (wrapper #'(lambda (&rest args)
298 (let ((*signal-stop-emission* signal-stop-emission))
299 (apply callback args)))))
3b8e5eb0 300 (multiple-value-bind (closure-id callback-id)
301 (make-callback-closure wrapper)
302 (let ((handler-id (%signal-connect-closure-by-id
54ea42fe 303 gobject signal-id detail-quark closure-id after)))
3b8e5eb0 304 (when remove
305 (update-user-data callback-id
306 #'(lambda (&rest args)
307 (unwind-protect
308 (let ((*signal-stop-emission* signal-stop-emission))
309 (apply callback args))
310 (signal-handler-disconnect gobject handler-id)))))
54ea42fe 311 handler-id))))
3b8e5eb0 312
313
314;;;; Signal emission
315
316(defbinding %signal-emitv () nil
317 (gvalues pointer)
318 (signal-id unsigned-int)
319 (detail quark)
320 (return-value gvalue))
321
322(defvar *signal-emit-functions* (make-hash-table))
323
324(defun create-signal-emit-function (signal-id)
325 (let ((info (signal-query signal-id)))
326 (let* ((type (type-from-number (slot-value info 'type)))
327 (param-types (cons type (signal-param-types info)))
328 (return-type (type-from-number (slot-value info 'return-type)))
329 (n-params (1+ (slot-value info 'n-params)))
330 (params (allocate-memory (* n-params +gvalue-size+))))
331 #'(lambda (detail object &rest args)
332 (unless (= (length args) (1- n-params))
333 (error "Invalid number of arguments: ~A" (+ 2 (length args))))
334 (unwind-protect
335 (loop
336 for arg in (cons object args)
337 for type in param-types
338 as tmp = params then (sap+ tmp +gvalue-size+)
339 do (gvalue-init tmp type arg)
340 finally
341 (if return-type
342 (return
343 (with-gvalue (return-value)
344 (%signal-emitv params signal-id detail return-value)))
345 (%signal-emitv params signal-id detail (make-pointer 0))))
346 (loop
347 repeat n-params
348 as tmp = params then (sap+ tmp +gvalue-size+)
349 while (gvalue-p tmp)
350 do (gvalue-unset tmp)))))))
351
352(defun signal-emit-with-detail (object signal detail &rest args)
353 (let* ((signal-id (ensure-signal-id signal object))
354 (function (or
355 (gethash signal-id *signal-emit-functions*)
356 (setf
357 (gethash signal-id *signal-emit-functions*)
358 (create-signal-emit-function signal-id)))))
359 (apply function detail object args)))
360
361(defun signal-emit (object signal &rest args)
362 (apply #'signal-emit-with-detail object signal 0 args))
363
dd181a20 364
11e1e57c 365;;;; Convenient macros
366
367(defmacro def-callback-marshal (name (return-type &rest args))
368 (let ((names (loop
369 for arg in args
370 collect (if (atom arg) (gensym) (first arg))))
371 (types (loop
372 for arg in args
373 collect (if (atom arg) arg (second arg)))))
374 `(defcallback ,name (,return-type ,@(mapcar #'list names types)
375 (callback-id unsigned-int))
376 (invoke-callback callback-id ',return-type ,@names))))
377
378(defmacro with-callback-function ((id function) &body body)
379 `(let ((,id (register-callback-function ,function)))
380 (unwind-protect
381 (progn ,@body)
382 (destroy-user-data ,id))))