3 (defcstruct lisp-signal-handler-closure
4 (:parent-instance g-closure)
8 (defun finalize-lisp-signal-handler-closure (closure)
9 (let* ((function-id (foreign-slot-value closure 'lisp-signal-handler-closure :function-id))
10 (addr (pointer-address (foreign-slot-value closure 'lisp-signal-handler-closure :object)))
11 (object (or (gethash addr *foreign-gobjects-strong*)
12 (gethash addr *foreign-gobjects-weak*))))
14 (delete-handler-from-object object function-id))))
16 (defcallback lisp-signal-handler-closure-finalize :void
17 ((data :pointer) (closure (:pointer lisp-signal-handler-closure)))
18 (declare (ignore data))
19 (finalize-lisp-signal-handler-closure closure))
21 (defun call-with-restarts (fn args)
24 (return-from-g-closure (&optional v) :report "Return value from closure" v)))
26 (defcallback lisp-signal-handler-closure-marshal :void
27 ((closure (:pointer lisp-signal-handler-closure))
28 (return-value (:pointer g-value))
30 (args (:pointer g-value))
31 (invocation-hint :pointer)
32 (marshal-data :pointer))
33 (declare (ignore invocation-hint marshal-data))
34 (let* ((args (parse-closure-arguments count-of-args args))
35 (function-id (foreign-slot-value closure 'lisp-signal-handler-closure :function-id))
36 (addr (pointer-address (foreign-slot-value closure 'lisp-signal-handler-closure :object)))
37 (object (or (gethash addr *foreign-gobjects-strong*)
38 (gethash addr *foreign-gobjects-weak*)))
39 (return-type (and (not (null-pointer-p return-value))
40 (g-value-type return-value)))
41 (fn (retrieve-handler-from-object object function-id))
42 (fn-result (call-with-restarts fn args)))
44 (set-g-value return-value fn-result return-type :g-value-init nil))))
46 (defun parse-closure-arguments (count-of-args args)
48 for i from 0 below count-of-args
49 collect (parse-g-value (mem-aref args 'g-value i))))
51 (defun create-signal-handler-closure (object fn)
52 (let ((function-id (save-handler-to-object object fn))
53 (closure (g-closure-new-simple (foreign-type-size 'lisp-signal-handler-closure) (null-pointer))))
54 (setf (foreign-slot-value closure 'lisp-signal-handler-closure :function-id) function-id
55 (foreign-slot-value closure 'lisp-signal-handler-closure :object) (pointer object))
56 (g-closure-add-finalize-notifier closure (null-pointer)
57 (callback lisp-signal-handler-closure-finalize))
58 (g-closure-set-marshal closure (callback lisp-signal-handler-closure-marshal))
61 (defun find-free-signal-handler-id (object)
62 (iter (with handlers = (g-object-signal-handlers object))
63 (for i from 0 below (length handlers))
64 (finding i such-that (null (aref handlers i)))))
66 (defun save-handler-to-object (object handler)
68 (let ((id (find-free-signal-handler-id object))
69 (handlers (g-object-signal-handlers object)))
71 (setf (aref handlers id) handler)
72 (vector-push-extend handler handlers))))
74 (defun retrieve-handler-from-object (object handler-id)
75 (aref (g-object-signal-handlers object) handler-id))
77 (defun delete-handler-from-object (object handler-id)
78 (let ((handlers (g-object-signal-handlers object)))
79 (setf (aref handlers handler-id) nil)
80 (iter (while (plusp (length handlers)))
81 (while (null (aref handlers (1- (length handlers)))))
82 (vector-pop handlers))
85 (defun connect-signal (object signal handler &key after)
86 "Connects the function to a signal for a particular object.
87 If @code{after} is true, then the function will be called after the default handler of the signal.
89 @arg[object]{an instance of @class{gobject}}
90 @arg[signal]{a string; names the signal}
91 @arg[handler]{a function; handles the signal. Number (and type) of arguments and return value type depends on the signal}
92 @arg[after]{a boolean}"
93 (g-signal-connect-closure (pointer object)
95 (create-signal-handler-closure object handler)
98 (defun g-signal-connect (object signal handler &key after)
99 "Deprecated alias for @fun{connect-signal}"
100 (connect-signal object signal handler :after after))
102 (defun emit-signal (object signal-name &rest args)
104 @arg[object]{an instance of @class{g-object}. Signal is emitted on this object}
105 @arg[signal-name]{a string specifying the signal}
106 @arg[args]{arguments for the signal}
108 (let* ((object-type (g-type-from-object (pointer object)))
109 (signal-info (parse-signal-name object-type signal-name)))
111 (error "Signal ~A not found on object ~A" signal-name object))
112 (let ((params-count (length (signal-info-param-types signal-info))))
113 (with-foreign-object (params 'g-value (1+ params-count))
114 (set-g-value (mem-aref params 'g-value 0) object object-type :zero-g-value t)
115 (iter (for i from 0 below params-count)
117 (for type in (signal-info-param-types signal-info))
118 (set-g-value (mem-aref params 'g-value (1+ i)) arg type :zero-g-value t))
120 (if (g-type= (signal-info-return-type signal-info) +g-type-void+)
121 (g-signal-emitv params (signal-info-id signal-info) signal-name (null-pointer))
122 (with-foreign-object (return-value 'g-value)
123 (g-value-zero return-value)
124 (g-value-init return-value (signal-info-return-type signal-info))
125 (prog1 (parse-g-value return-value)
126 (g-value-unset return-value))))
127 (iter (for i from 0 below (1+ params-count))
128 (g-value-unset (mem-aref params 'g-value i))))))))