- (handler unsigned-int))
-
-
-(defmethod signal-connect ((gobject gobject) signal function &key after object)
-"Connects a callback function to a signal for a particular object. If :OBJECT
- is T, the object connected to is passed as the first argument to the callback
- function, or if :OBJECT is any other non NIL value, it is passed as the first
- argument instead. If :AFTER is non NIL, the handler will be called after the
- default handler of the signal."
- (let ((callback-id
- (make-callback-closure
- (cond
- ((or (eq object t) (eq object gobject)) function)
- ((not object)
- #'(lambda (&rest args) (apply function (cdr args))))
- (t
- #'(lambda (&rest args) (apply function object (rest args))))))))
- (signal-connect-closure gobject signal callback-id :after after)))
+ (handler-id unsigned-int))
+
+(defbinding signal-handler-is-connected-p () boolean
+ (instance ginstance)
+ (handler-id unsigned-int))
+
+(deftype gclosure () 'pointer)
+
+(defbinding (callback-closure-new "clg_callback_closure_new") () gclosure
+ (callback-id unsigned-int)
+ (callback pointer)
+ (destroy-notify pointer))
+
+(defun make-callback-closure (function)
+ (let ((callback-id (register-callback-function function)))
+ (values
+ (callback-closure-new
+ callback-id (callback closure-marshal)
+ (callback %destroy-user-data))
+ callback-id)))
+
+(defmethod create-callback-function ((gobject gobject) function arg1)
+ (cond
+ ((or (eq arg1 t) (eq arg1 gobject)) function)
+ ((not arg1)
+ #'(lambda (&rest args) (apply function (rest args))))
+ (t
+ #'(lambda (&rest args) (apply function arg1 (rest args))))))
+
+(defmethod signal-connect ((gobject gobject) signal function
+ &key (detail 0) after object remove)
+"Connects a callback function to a signal for a particular object. If
+:OBJECT is T, the object connected to is passed as the first argument
+to the callback function, or if :OBJECT is any other non NIL value, it
+is passed as the first argument instead. If :AFTER is non NIL, the
+handler will be called after the default handler for the signal. If
+:REMOVE is non NIL, the handler will be removed after beeing invoked
+once."
+ (when function
+ (let* ((signal-id (ensure-signal-id signal gobject))
+ (signal-stop-emission
+ #'(lambda ()
+ (%signal-stop-emission gobject signal-id detail)))
+ (callback (create-callback-function gobject function object))
+ (wrapper #'(lambda (&rest args)
+ (let ((*signal-stop-emission* signal-stop-emission))
+ (apply callback args)))))
+ (multiple-value-bind (closure-id callback-id)
+ (make-callback-closure wrapper)
+ (let ((handler-id (%signal-connect-closure-by-id
+ gobject signal-id detail closure-id after)))
+ (when remove
+ (update-user-data callback-id
+ #'(lambda (&rest args)
+ (unwind-protect
+ (let ((*signal-stop-emission* signal-stop-emission))
+ (apply callback args))
+ (signal-handler-disconnect gobject handler-id)))))
+ handler-id)))))
+
+
+;;;; Signal emission
+
+(defbinding %signal-emitv () nil
+ (gvalues pointer)
+ (signal-id unsigned-int)
+ (detail quark)
+ (return-value gvalue))
+
+(defvar *signal-emit-functions* (make-hash-table))
+
+(defun create-signal-emit-function (signal-id)
+ (let ((info (signal-query signal-id)))
+ (let* ((type (type-from-number (slot-value info 'type)))
+ (param-types (cons type (signal-param-types info)))
+ (return-type (type-from-number (slot-value info 'return-type)))
+ (n-params (1+ (slot-value info 'n-params)))
+ (params (allocate-memory (* n-params +gvalue-size+))))
+ #'(lambda (detail object &rest args)
+ (unless (= (length args) (1- n-params))
+ (error "Invalid number of arguments: ~A" (+ 2 (length args))))
+ (unwind-protect
+ (loop
+ for arg in (cons object args)
+ for type in param-types
+ as tmp = params then (sap+ tmp +gvalue-size+)
+ do (gvalue-init tmp type arg)
+ finally
+ (if return-type
+ (return
+ (with-gvalue (return-value)
+ (%signal-emitv params signal-id detail return-value)))
+ (%signal-emitv params signal-id detail (make-pointer 0))))
+ (loop
+ repeat n-params
+ as tmp = params then (sap+ tmp +gvalue-size+)
+ while (gvalue-p tmp)
+ do (gvalue-unset tmp)))))))
+
+(defun signal-emit-with-detail (object signal detail &rest args)
+ (let* ((signal-id (ensure-signal-id signal object))
+ (function (or
+ (gethash signal-id *signal-emit-functions*)
+ (setf
+ (gethash signal-id *signal-emit-functions*)
+ (create-signal-emit-function signal-id)))))
+ (apply function detail object args)))
+
+(defun signal-emit (object signal &rest args)
+ (apply #'signal-emit-with-detail object signal 0 args))
+
~mdw / clg / blobdiff