1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
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.
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.
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
18 ;; $Id: gcallback.lisp,v 1.23 2005-03-06 17:18:00 espen Exp $
25 ;;;; Callback invokation
27 (defun register-callback-function (function)
28 (check-type function (or null symbol function))
29 (register-user-data function))
31 ;; Callback marshal for regular signal handlers
32 (defcallback closure-marshal (nil
35 (n-params unsigned-int)
36 (param-values pointer)
37 (invocation-hint pointer)
38 (callback-id unsigned-int))
39 (declare (ignore gclosure invocation-hint))
40 (callback-trampoline callback-id n-params param-values return-value))
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))
50 (defun callback-trampoline (callback-id n-params param-values &optional
51 (return-value (make-pointer 0)))
52 (let* ((return-type (unless (null-pointer-p return-value)
53 (gvalue-type return-value)))
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)))
59 (gvalue-set return-value result)))))
61 (defun invoke-callback (callback-id return-type &rest args)
63 (apply (find-user-data callback-id) args)
64 (continue nil :report "Return from callback function"
66 (format *query-io* "Enter return value of type ~S: " return-type)
67 (force-output *query-io*)
68 (eval (read *query-io*))))
69 (re-invoke nil :report "Re-invoke callback function"
70 (apply #'invoke-callback callback-id return-type args))))
73 ;;;; Timeouts and idle functions
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)
81 (defbinding source-remove () boolean
84 (defcallback source-callback-marshal (nil (callback-id unsigned-int))
85 (callback-trampoline callback-id 0 nil))
87 (defbinding (timeout-add "g_timeout_add_full")
88 (interval function &optional (priority +priority-default+)) unsigned-int
90 (interval unsigned-int)
91 ((callback source-callback-marshal) pointer)
92 ((register-callback-function function) unsigned-long)
93 ((callback user-data-destroy-func) pointer))
95 (defun timeout-remove (timeout)
96 (source-remove timeout))
98 (defbinding (idle-add "g_idle_add_full")
99 (function &optional (priority +priority-default-idle+)) unsigned-int
101 ((callback source-callback-marshal) pointer)
102 ((register-callback-function function) unsigned-long)
103 ((callback user-data-destroy-func) pointer))
105 (defun idle-remove (idle)
106 (source-remove idle))
109 ;;;; Signal information querying
111 (defbinding signal-lookup (name type) unsigned-int
112 ((signal-name-to-string name) string)
113 ((find-type-number type t) type-number))
115 (defbinding signal-name () (copy-of string)
116 (signal-id unsigned-int))
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))
122 (defun signal-list-names (type)
123 (map 'list #'signal-name (signal-list-ids type)))
125 (defun ensure-signal-id-from-type (signal-id type)
127 (integer (if (signal-name signal-id)
129 (error "Invalid signal id: ~D" signal-id)))
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)
136 (defun ensure-signal-id (signal-id instance)
137 (ensure-signal-id-from-type signal-id (type-of instance)))
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))
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)))
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))
159 (defun signal-param-types (info)
160 (with-slots (n-params param-types) info
162 #'(lambda (type-number)
163 (type-from-number type-number))
164 param-types 'type-number n-params)))
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~%"
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))))
178 (format nil "arguments with the following types: ~A"
179 (signal-param-types info)))))))
182 ;;;; Signal connecting and controlling
184 (defbinding %signal-stop-emission () nil
186 (signal-id unsigned-int)
189 (defvar *signal-stop-emission* nil)
190 (declaim (special *signal-stop-emission*))
192 (defun signal-stop-emission ()
193 (if *signal-stop-emission*
194 (funcall *signal-stop-emission*)
195 (error "Not inside a signal handler")))
198 (defbinding signal-add-emission-hook (type signal function &key (detail 0))
200 ((ensure-signal-id-from-type signal type) unsigned-int)
202 ((callback signal-emission-hook) pointer)
203 ((register-callback-function function) unsigned-int)
204 ((callback user-data-destroy-func) pointer))
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))
211 (defbinding (signal-has-handler-pending-p "g_signal_has_handler_pending")
212 (instance signal-id &key detail blocked) boolean
214 ((ensure-signal-id signal-id instance) unsigned-int)
215 ((or detail 0) quark)
218 (defbinding %signal-connect-closure-by-id () unsigned-int
220 (signal-id unsigned-int)
225 (defbinding signal-handler-block () nil
227 (handler-id unsigned-int))
229 (defbinding signal-handler-unblock () nil
231 (handler-id unsigned-int))
233 (defbinding signal-handler-disconnect () nil
235 (handler-id unsigned-int))
237 (defbinding signal-handler-is-connected-p () boolean
239 (handler-id unsigned-int))
241 (deftype gclosure () 'pointer)
243 (defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
244 (callback-id unsigned-int)
246 (destroy-notify pointer))
248 (defun make-callback-closure (function)
249 (let ((callback-id (register-callback-function function)))
251 (callback-closure-new
252 callback-id (callback closure-marshal)
253 (callback user-data-destroy-func))
256 (defgeneric compute-signal-function (gobject signal function object))
258 (defmethod compute-signal-function ((gobject gobject) signal function object)
259 (declare (ignore signal))
261 ((or (eq object t) (eq object gobject)) function)
263 #'(lambda (&rest args) (apply function (rest args))))
265 #'(lambda (&rest args) (apply function object (rest args))))))
268 (defgeneric compute-signal-id (gobject signal))
270 (defmethod compute-signal-id ((gobject gobject) signal)
271 (ensure-signal-id signal gobject))
274 (defgeneric signal-connect (gobject signal function &key detail after object remove))
276 (defmethod signal-connect :around ((gobject gobject) signal function &rest args)
277 (declare (ignore gobject signal args))
282 (defmethod signal-connect ((gobject gobject) signal function
283 &key detail after object remove)
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
286 to the callback function, or if :OBJECT is any other non NIL value, it
287 is passed as the first argument instead. If :AFTER is non NIL, the
288 handler will be called after the default handler for the signal. If
289 :REMOVE is non NIL, the handler will be removed after beeing invoked
291 (let* ((signal-id (compute-signal-id gobject signal))
292 (detail-quark (if detail (quark-intern detail) 0))
293 (signal-stop-emission
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)))))
300 (multiple-value-bind (closure-id callback-id)
301 (make-callback-closure wrapper)
302 (let ((handler-id (%signal-connect-closure-by-id
303 gobject signal-id detail-quark closure-id after)))
305 (update-user-data callback-id
306 #'(lambda (&rest args)
308 (let ((*signal-stop-emission* signal-stop-emission))
309 (apply callback args))
310 (signal-handler-disconnect gobject handler-id)))))
316 (defbinding %signal-emitv () nil
318 (signal-id unsigned-int)
320 (return-value gvalue))
322 (defvar *signal-emit-functions* (make-hash-table))
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))))
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)
343 (with-gvalue (return-value)
344 (%signal-emitv params signal-id detail return-value)))
345 (%signal-emitv params signal-id detail (make-pointer 0))))
348 as tmp = params then (sap+ tmp +gvalue-size+)
350 do (gvalue-unset tmp)))))))
352 (defun signal-emit-with-detail (object signal detail &rest args)
353 (let* ((signal-id (ensure-signal-id signal object))
355 (gethash signal-id *signal-emit-functions*)
357 (gethash signal-id *signal-emit-functions*)
358 (create-signal-emit-function signal-id)))))
359 (apply function detail object args)))
361 (defun signal-emit (object signal &rest args)
362 (apply #'signal-emit-with-detail object signal 0 args))
365 ;;;; Convenient macros
367 (defmacro def-callback-marshal (name (return-type &rest args))
370 collect (if (atom arg) (gensym) (first arg))))
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))))
378 (defmacro with-callback-function ((id function) &body body)
379 `(let ((,id (register-callback-function ,function)))
382 (destroy-user-data ,id))))