chiark / gitweb /
Added dependency to the gtk system and a couple of bug fixes
[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
266ca870 18;; $Id: gcallback.lisp,v 1.23 2005-03-06 17:18:00 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))
266ca870 39 (declare (ignore gclosure invocation-hint))
e0d2987b 40 (callback-trampoline callback-id n-params param-values return-value))
c8c48a4c 41
e0d2987b 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)))
c8c48a4c 52 (let* ((return-type (unless (null-pointer-p return-value)
e378b861 53 (gvalue-type return-value)))
34f9e1d4 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
8755b1a5 61(defun invoke-callback (callback-id return-type &rest args)
34f9e1d4 62 (restart-case
63 (apply (find-user-data callback-id) args)
64 (continue nil :report "Return from callback function"
8755b1a5 65 (when return-type
66 (format *query-io* "Enter return value of type ~S: " return-type)
34f9e1d4 67 (force-output *query-io*)
68 (eval (read *query-io*))))
69 (re-invoke nil :report "Re-invoke callback function"
8755b1a5 70 (apply #'invoke-callback callback-id return-type args))))
c8c48a4c 71
c8c48a4c 72
e378b861 73;;;; Timeouts and idle functions
74
acd28982 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
8755b1a5 84(defcallback source-callback-marshal (nil (callback-id unsigned-int))
e0d2987b 85 (callback-trampoline callback-id 0 nil))
e378b861 86
87(defbinding (timeout-add "g_timeout_add_full")
acd28982 88 (interval function &optional (priority +priority-default+)) unsigned-int
e378b861 89 (priority int)
90 (interval unsigned-int)
acd28982 91 ((callback source-callback-marshal) pointer)
e378b861 92 ((register-callback-function function) unsigned-long)
73572c12 93 ((callback user-data-destroy-func) pointer))
e378b861 94
acd28982 95(defun timeout-remove (timeout)
96 (source-remove timeout))
97
e378b861 98(defbinding (idle-add "g_idle_add_full")
acd28982 99 (function &optional (priority +priority-default-idle+)) unsigned-int
e378b861 100 (priority int)
acd28982 101 ((callback source-callback-marshal) pointer)
e378b861 102 ((register-callback-function function) unsigned-long)
73572c12 103 ((callback user-data-destroy-func) pointer))
e378b861 104
acd28982 105(defun idle-remove (idle)
106 (source-remove idle))
e378b861 107
c8c48a4c 108
e0d2987b 109;;;; Signal information querying
c8c48a4c 110
e0d2987b 111(defbinding signal-lookup (name type) unsigned-int
c8c48a4c 112 ((signal-name-to-string name) string)
e0d2987b 113 ((find-type-number type t) type-number))
c8c48a4c 114
e0d2987b 115(defbinding signal-name () (copy-of string)
c8c48a4c 116 (signal-id unsigned-int))
117
e0d2987b 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)
c8c48a4c 126 (etypecase signal-id
e0d2987b 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)))
c8c48a4c 138
e0d2987b 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
c8c48a4c 185 (instance ginstance)
e0d2987b 186 (signal-id unsigned-int)
187 (detail quark))
188
189(defvar *signal-stop-emission* nil)
190(declaim (special *signal-stop-emission*))
c8c48a4c 191
e0d2987b 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)
73572c12 204 ((callback user-data-destroy-func) pointer))
e0d2987b 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))
c8c48a4c 209
c8c48a4c 210
0383dd48 211(defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
c8c48a4c 212 (instance signal-id &key detail blocked) boolean
213 (instance ginstance)
e49e135a 214 ((ensure-signal-id signal-id instance) unsigned-int)
c8c48a4c 215 ((or detail 0) quark)
73572c12 216 (blocked boolean))
c8c48a4c 217
e0d2987b 218(defbinding %signal-connect-closure-by-id () unsigned-int
c8c48a4c 219 (instance ginstance)
e0d2987b 220 (signal-id unsigned-int)
221 (detail quark)
222 (closure pointer)
c8c48a4c 223 (after boolean))
224
0383dd48 225(defbinding signal-handler-block () nil
c8c48a4c 226 (instance ginstance)
e0d2987b 227 (handler-id unsigned-int))
c8c48a4c 228
0383dd48 229(defbinding signal-handler-unblock () nil
c8c48a4c 230 (instance ginstance)
e0d2987b 231 (handler-id unsigned-int))
c8c48a4c 232
0383dd48 233(defbinding signal-handler-disconnect () nil
c8c48a4c 234 (instance ginstance)
e0d2987b 235 (handler-id unsigned-int))
236
237(defbinding signal-handler-is-connected-p () boolean
238 (instance ginstance)
239 (handler-id unsigned-int))
c8c48a4c 240
d75a77ff 241(deftype gclosure () 'pointer)
242
243(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
e0d2987b 244 (callback-id unsigned-int)
245 (callback pointer)
246 (destroy-notify pointer))
c8c48a4c 247
e0d2987b 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)
73572c12 253 (callback user-data-destroy-func))
e0d2987b 254 callback-id)))
255
cd9b9e8b 256(defgeneric compute-signal-function (gobject signal function object))
65670fe5 257
cd9b9e8b 258(defmethod compute-signal-function ((gobject gobject) signal function object)
259 (declare (ignore signal))
e0d2987b 260 (cond
cd9b9e8b 261 ((or (eq object t) (eq object gobject)) function)
262 ((not object)
e0d2987b 263 #'(lambda (&rest args) (apply function (rest args))))
264 (t
cd9b9e8b 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)))
e0d2987b 280
65670fe5 281
e0d2987b 282(defmethod signal-connect ((gobject gobject) signal function
cd9b9e8b 283 &key detail after object remove)
e0d2987b 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."
cd9b9e8b 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)))))
e0d2987b 300 (multiple-value-bind (closure-id callback-id)
301 (make-callback-closure wrapper)
302 (let ((handler-id (%signal-connect-closure-by-id
cd9b9e8b 303 gobject signal-id detail-quark closure-id after)))
e0d2987b 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)))))
cd9b9e8b 311 handler-id))))
e0d2987b 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
c0f178d0 364
fd1e4a39 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))))