+ (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))
+
+
+
+;;; Message logging
+
+;; TODO: define and signal conditions based on log-level
+
+(def-callback log-handler (c-call:void (domain c-call:c-string)
+ (log-level c-call:int)
+ (message c-call:c-string))
+ (error "~A: ~A" domain message))
+
+(setf (extern-alien "log_handler" system-area-pointer) (callback log-handler))
+
+
+;;;; Convenient macros
+
+(defmacro def-callback-marshal (name (return-type &rest args))
+ (let ((names (loop
+ for arg in args
+ collect (if (atom arg) (gensym) (first arg))))
+ (types (loop
+ for arg in args
+ collect (if (atom arg) arg (second arg)))))
+ `(defcallback ,name (,return-type ,@(mapcar #'list names types)
+ (callback-id unsigned-int))
+ (invoke-callback callback-id ',return-type ,@names))))
+
+(defmacro with-callback-function ((id function) &body body)
+ `(let ((,id (register-callback-function ,function)))
+ (unwind-protect
+ (progn ,@body)
+ (destroy-user-data ,id))))
~mdw / clg / blobdiff