chiark / gitweb /
Defined callback as a foreign type
[clg] / glib / gcallback.lisp
CommitLineData
c8c48a4c 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
65670fe5 18;; $Id: gcallback.lisp,v 1.21 2005-02-14 00:41:54 espen Exp $
c8c48a4c 19
20(in-package "GLIB")
21
22(use-prefix "g")
23
24
e0d2987b 25;;;; Callback invokation
c8c48a4c 26
e378b861 27(defun register-callback-function (function)
28 (check-type function (or null symbol function))
29 (register-user-data function))
c8c48a4c 30
e0d2987b 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))
39 (callback-trampoline callback-id n-params param-values return-value))
c8c48a4c 40
e0d2987b 41;; Callback function for emission hooks
42(defcallback signal-emission-hook (nil
43 (invocation-hint pointer)
44 (n-params unsigned-int)
45 (param-values pointer)
46 (callback-id unsigned-int))
47 (callback-trampoline callback-id n-params param-values))
48
49(defun callback-trampoline (callback-id n-params param-values &optional
50 (return-value (make-pointer 0)))
c8c48a4c 51 (let* ((return-type (unless (null-pointer-p return-value)
e378b861 52 (gvalue-type return-value)))
34f9e1d4 53 (args (loop
54 for n from 0 below n-params
55 collect (gvalue-get (sap+ param-values (* n +gvalue-size+))))))
56 (let ((result (apply #'invoke-callback callback-id return-type args)))
57 (when return-type
58 (gvalue-set return-value result)))))
59
8755b1a5 60(defun invoke-callback (callback-id return-type &rest args)
34f9e1d4 61 (restart-case
62 (apply (find-user-data callback-id) args)
63 (continue nil :report "Return from callback function"
8755b1a5 64 (when return-type
65 (format *query-io* "Enter return value of type ~S: " return-type)
34f9e1d4 66 (force-output *query-io*)
67 (eval (read *query-io*))))
68 (re-invoke nil :report "Re-invoke callback function"
8755b1a5 69 (apply #'invoke-callback callback-id return-type args))))
c8c48a4c 70
c8c48a4c 71
e378b861 72;;;; Timeouts and idle functions
73
acd28982 74(defconstant +priority-high+ -100)
75(defconstant +priority-default+ 0)
76(defconstant +priority-high-idle+ 100)
77(defconstant +priority-default-idle+ 200)
78(defconstant +priority-low+ 300)
79
80(defbinding source-remove () boolean
81 (tag unsigned-int))
82
8755b1a5 83(defcallback source-callback-marshal (nil (callback-id unsigned-int))
e0d2987b 84 (callback-trampoline callback-id 0 nil))
e378b861 85
86(defbinding (timeout-add "g_timeout_add_full")
acd28982 87 (interval function &optional (priority +priority-default+)) unsigned-int
e378b861 88 (priority int)
89 (interval unsigned-int)
acd28982 90 ((callback source-callback-marshal) pointer)
e378b861 91 ((register-callback-function function) unsigned-long)
73572c12 92 ((callback user-data-destroy-func) pointer))
e378b861 93
acd28982 94(defun timeout-remove (timeout)
95 (source-remove timeout))
96
e378b861 97(defbinding (idle-add "g_idle_add_full")
acd28982 98 (function &optional (priority +priority-default-idle+)) unsigned-int
e378b861 99 (priority int)
acd28982 100 ((callback source-callback-marshal) pointer)
e378b861 101 ((register-callback-function function) unsigned-long)
73572c12 102 ((callback user-data-destroy-func) pointer))
e378b861 103
acd28982 104(defun idle-remove (idle)
105 (source-remove idle))
e378b861 106
c8c48a4c 107
e0d2987b 108;;;; Signal information querying
c8c48a4c 109
e0d2987b 110(defbinding signal-lookup (name type) unsigned-int
c8c48a4c 111 ((signal-name-to-string name) string)
e0d2987b 112 ((find-type-number type t) type-number))
c8c48a4c 113
e0d2987b 114(defbinding signal-name () (copy-of string)
c8c48a4c 115 (signal-id unsigned-int))
116
e0d2987b 117(defbinding signal-list-ids (type) (vector unsigned-int n-ids)
118 ((find-type-number type t) type-number)
119 (n-ids unsigned-int :out))
120
121(defun signal-list-names (type)
122 (map 'list #'signal-name (signal-list-ids type)))
123
124(defun ensure-signal-id-from-type (signal-id type)
c8c48a4c 125 (etypecase signal-id
e0d2987b 126 (integer (if (signal-name signal-id)
127 signal-id
128 (error "Invalid signal id: ~D" signal-id)))
129 ((or symbol string)
130 (let ((numeric-id (signal-lookup signal-id type)))
131 (if (zerop numeric-id)
132 (error "Invalid signal name for ~S: ~D" type signal-id)
133 numeric-id)))))
134
135(defun ensure-signal-id (signal-id instance)
136 (ensure-signal-id-from-type signal-id (type-of instance)))
c8c48a4c 137
e0d2987b 138(eval-when (:compile-toplevel :load-toplevel :execute)
139 (deftype signal-flags ()
140 '(flags :run-first :run-last :run-cleanup :no-recurse
141 :detailed :action :no-hooks))
142
143 (defclass signal-query (struct)
144 ((id :allocation :alien :type unsigned-int)
145 (name :allocation :alien :type (copy-of string))
146 (type :allocation :alien :type type-number)
147 (flags :allocation :alien :type signal-flags)
148 (return-type :allocation :alien :type type-number)
149 (n-params :allocation :alien :type unsigned-int)
150 (param-types :allocation :alien :type pointer))
151 (:metaclass struct-class)))
152
153(defbinding signal-query
154 (signal-id &optional (signal-query (make-instance 'signal-query))) nil
155 (signal-id unsigned-int)
156 (signal-query signal-query :return))
157
158(defun signal-param-types (info)
159 (with-slots (n-params param-types) info
160 (map-c-vector 'list
161 #'(lambda (type-number)
162 (type-from-number type-number))
163 param-types 'type-number n-params)))
164
165
166(defun describe-signal (signal-id &optional type)
167 (let ((info (signal-query (ensure-signal-id-from-type signal-id type))))
168 (with-slots (id name type flags return-type n-params) info
169 (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))
170 (format t "Signal handlers should return ~A and take ~A~%"
171 (cond
172 ((= return-type (find-type-number "void")) "no values")
173 ((not (type-from-number return-type)) "values of unknown type")
174 ((format nil "values of type ~S" (type-from-number return-type))))
175 (if (zerop n-params)
176 "no arguments"
177 (format nil "arguments with the following types: ~A"
178 (signal-param-types info)))))))
179
180
181;;;; Signal connecting and controlling
182
183(defbinding %signal-stop-emission () nil
c8c48a4c 184 (instance ginstance)
e0d2987b 185 (signal-id unsigned-int)
186 (detail quark))
187
188(defvar *signal-stop-emission* nil)
189(declaim (special *signal-stop-emission*))
c8c48a4c 190
e0d2987b 191(defun signal-stop-emission ()
192 (if *signal-stop-emission*
193 (funcall *signal-stop-emission*)
194 (error "Not inside a signal handler")))
195
196
197(defbinding signal-add-emission-hook (type signal function &key (detail 0))
198 unsigned-int
199 ((ensure-signal-id-from-type signal type) unsigned-int)
200 (detail quark)
201 ((callback signal-emission-hook) pointer)
202 ((register-callback-function function) unsigned-int)
73572c12 203 ((callback user-data-destroy-func) pointer))
e0d2987b 204
205(defbinding signal-remove-emission-hook (type signal hook-id) nil
206 ((ensure-signal-id-from-type signal type) unsigned-int)
207 (hook-id unsigned-int))
c8c48a4c 208
c8c48a4c 209
0383dd48 210(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c8c48a4c 211 (instance signal-id &key detail blocked) boolean
212 (instance ginstance)
e49e135a 213 ((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c 214 ((or detail 0) quark)
73572c12 215 (blocked boolean))
c8c48a4c 216
e0d2987b 217(defbinding %signal-connect-closure-by-id () unsigned-int
c8c48a4c 218 (instance ginstance)
e0d2987b 219 (signal-id unsigned-int)
220 (detail quark)
221 (closure pointer)
c8c48a4c 222 (after boolean))
223
0383dd48 224(defbinding signal-handler-block () nil
c8c48a4c 225 (instance ginstance)
e0d2987b 226 (handler-id unsigned-int))
c8c48a4c 227
0383dd48 228(defbinding signal-handler-unblock () nil
c8c48a4c 229 (instance ginstance)
e0d2987b 230 (handler-id unsigned-int))
c8c48a4c 231
0383dd48 232(defbinding signal-handler-disconnect () nil
c8c48a4c 233 (instance ginstance)
e0d2987b 234 (handler-id unsigned-int))
235
236(defbinding signal-handler-is-connected-p () boolean
237 (instance ginstance)
238 (handler-id unsigned-int))
c8c48a4c 239
d75a77ff 240(deftype gclosure () 'pointer)
241
242(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
e0d2987b 243 (callback-id unsigned-int)
244 (callback pointer)
245 (destroy-notify pointer))
c8c48a4c 246
e0d2987b 247(defun make-callback-closure (function)
248 (let ((callback-id (register-callback-function function)))
249 (values
250 (callback-closure-new
251 callback-id (callback closure-marshal)
73572c12 252 (callback user-data-destroy-func))
e0d2987b 253 callback-id)))
254
65670fe5 255(defgeneric create-callback-function (gobject function arg1))
256
e0d2987b 257(defmethod create-callback-function ((gobject gobject) function arg1)
258 (cond
259 ((or (eq arg1 t) (eq arg1 gobject)) function)
260 ((not arg1)
261 #'(lambda (&rest args) (apply function (rest args))))
262 (t
263 #'(lambda (&rest args) (apply function arg1 (rest args))))))
264
65670fe5 265(defgeneric signal-connect (gobject signal function &key))
266
e0d2987b 267(defmethod signal-connect ((gobject gobject) signal function
268 &key (detail 0) after object remove)
269"Connects a callback function to a signal for a particular object. If
270:OBJECT is T, the object connected to is passed as the first argument
271to the callback function, or if :OBJECT is any other non NIL value, it
272is passed as the first argument instead. If :AFTER is non NIL, the
273handler will be called after the default handler for the signal. If
274:REMOVE is non NIL, the handler will be removed after beeing invoked
275once."
0f152c4e 276 (when function
e0d2987b 277 (let* ((signal-id (ensure-signal-id signal gobject))
278 (signal-stop-emission
279 #'(lambda ()
280 (%signal-stop-emission gobject signal-id detail)))
281 (callback (create-callback-function gobject function object))
282 (wrapper #'(lambda (&rest args)
283 (let ((*signal-stop-emission* signal-stop-emission))
284 (apply callback args)))))
285 (multiple-value-bind (closure-id callback-id)
286 (make-callback-closure wrapper)
287 (let ((handler-id (%signal-connect-closure-by-id
288 gobject signal-id detail closure-id after)))
289 (when remove
290 (update-user-data callback-id
291 #'(lambda (&rest args)
292 (unwind-protect
293 (let ((*signal-stop-emission* signal-stop-emission))
294 (apply callback args))
295 (signal-handler-disconnect gobject handler-id)))))
296 handler-id)))))
297
298
299;;;; Signal emission
300
301(defbinding %signal-emitv () nil
302 (gvalues pointer)
303 (signal-id unsigned-int)
304 (detail quark)
305 (return-value gvalue))
306
307(defvar *signal-emit-functions* (make-hash-table))
308
309(defun create-signal-emit-function (signal-id)
310 (let ((info (signal-query signal-id)))
311 (let* ((type (type-from-number (slot-value info 'type)))
312 (param-types (cons type (signal-param-types info)))
313 (return-type (type-from-number (slot-value info 'return-type)))
314 (n-params (1+ (slot-value info 'n-params)))
315 (params (allocate-memory (* n-params +gvalue-size+))))
316 #'(lambda (detail object &rest args)
317 (unless (= (length args) (1- n-params))
318 (error "Invalid number of arguments: ~A" (+ 2 (length args))))
319 (unwind-protect
320 (loop
321 for arg in (cons object args)
322 for type in param-types
323 as tmp = params then (sap+ tmp +gvalue-size+)
324 do (gvalue-init tmp type arg)
325 finally
326 (if return-type
327 (return
328 (with-gvalue (return-value)
329 (%signal-emitv params signal-id detail return-value)))
330 (%signal-emitv params signal-id detail (make-pointer 0))))
331 (loop
332 repeat n-params
333 as tmp = params then (sap+ tmp +gvalue-size+)
334 while (gvalue-p tmp)
335 do (gvalue-unset tmp)))))))
336
337(defun signal-emit-with-detail (object signal detail &rest args)
338 (let* ((signal-id (ensure-signal-id signal object))
339 (function (or
340 (gethash signal-id *signal-emit-functions*)
341 (setf
342 (gethash signal-id *signal-emit-functions*)
343 (create-signal-emit-function signal-id)))))
344 (apply function detail object args)))
345
346(defun signal-emit (object signal &rest args)
347 (apply #'signal-emit-with-detail object signal 0 args))
348
c0f178d0 349
fd1e4a39 350;;;; Convenient macros
351
352(defmacro def-callback-marshal (name (return-type &rest args))
353 (let ((names (loop
354 for arg in args
355 collect (if (atom arg) (gensym) (first arg))))
356 (types (loop
357 for arg in args
358 collect (if (atom arg) arg (second arg)))))
359 `(defcallback ,name (,return-type ,@(mapcar #'list names types)
360 (callback-id unsigned-int))
361 (invoke-callback callback-id ',return-type ,@names))))
362
363(defmacro with-callback-function ((id function) &body body)
364 `(let ((,id (register-callback-function ,function)))
365 (unwind-protect
366 (progn ,@body)
367 (destroy-user-data ,id))))