;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: gcallback.lisp,v 1.46 2007-08-20 11:15:13 espen Exp $
+;; $Id: gcallback.lisp,v 1.51 2009-02-10 15:18:15 espen Exp $
(in-package "GLIB")
((signal-name-to-string name) string)
((find-type-number type t) type-number))
-(defbinding signal-name () (copy-of string)
+(defbinding signal-name () (or null (copy-of string))
(signal-id unsigned-int))
(defbinding signal-list-ids (type) (vector unsigned-int n-ids)
;;;; Signal connecting and controlling
-(defvar *overridden-signals* (make-hash-table :test 'equalp))
+(define-flags-type connect-flags :after :swapped)
-(defbinding %signal-override-class-closure () nil
+(defvar *signal-override-closures* (make-hash-table :test 'equalp))
+
+(defbinding %%signal-override-class-closure () nil
(signal-id unsigned-int)
(type-number type-number)
(callback-closure pointer))
+(defun %signal-override-class-closure (type name function)
+ (multiple-value-bind (callback-closure callback-id)
+ (make-callback-closure function class-handler-marshal)
+ (let ((signal-id (ensure-signal-id-from-type name type)))
+ (%%signal-override-class-closure signal-id (find-type-number type t) callback-closure))
+ (setf
+ (gethash (list type name) *signal-override-closures*)
+ (list callback-id function))))
+
(defun signal-override-class-closure (name type function)
- (let* ((signal-id (ensure-signal-id-from-type name type))
- (type-number (find-type-number type t))
- (callback-id (gethash (cons type-number signal-id) *overridden-signals*)))
+ (let ((callback-id
+ (first (gethash (list type name) *signal-override-closures*))))
(if callback-id
(update-user-data callback-id function)
- (multiple-value-bind (callback-closure callback-id)
- (make-callback-closure function class-handler-marshal)
- (%signal-override-class-closure signal-id type-number callback-closure)
- (setf
- (gethash (cons type-number signal-id) *overridden-signals*)
- callback-id)))))
+ (%signal-override-class-closure type name function))))
+(defun reinitialize-signal-override-class-closures ()
+ (maphash
+ #'(lambda (key value)
+ (destructuring-bind (type name) key
+ (destructuring-bind (callback-id function) value
+ (declare (ignore callback-id))
+ (%signal-override-class-closure type name function))))
+ *signal-override-closures*))
(defbinding %signal-chain-from-overridden () nil
(args pointer)
do (gvalue-unset (pointer+ params offset)))
(deallocate-memory params)))))
-
(defmacro define-signal-handler (name ((object class) &rest args) &body body)
(let* ((info (signal-query (ensure-signal-id-from-type name class)))
(types (cons class (signal-param-types info)))
:REMOVE is non NIL, the handler will be removed after beeing invoked
once. ARGS is a list of additional arguments passed to the callback
function."
-(let* ((signal-id (compute-signal-id gobject signal))
- (detail-quark (if detail (quark-intern detail) 0))
- (signal-stop-emission
- #'(lambda ()
- (%signal-stop-emission gobject signal-id detail-quark)))
- (callback (compute-signal-function gobject signal function object args))
- (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 signal-handler-marshal)
- (let ((handler-id (%signal-connect-closure-by-id
- gobject signal-id detail-quark closure-id after)))
- (when remove
- (update-user-data callback-id
- #'(lambda (&rest args)
+ (let* ((signal-id (compute-signal-id gobject signal))
+ (detail-quark (if detail (quark-intern detail) 0))
+ (callback
+ (compute-signal-function gobject signal function object args))
+ (wrapper
+ #'(lambda (&rest args)
+ (let ((*signal-stop-emission*
+ #'(lambda ()
+ (%signal-stop-emission (first args)
+ signal-id detail-quark))))
+ (apply callback args)))))
+ (multiple-value-bind (closure-id callback-id)
+ (make-callback-closure wrapper signal-handler-marshal)
+ (let ((handler-id (%signal-connect-closure-by-id
+ gobject signal-id detail-quark closure-id after)))
+ (when remove
+ (update-user-data callback-id
+ #'(lambda (&rest args)
+ (let ((gobject (first args)))
(unwind-protect
- (let ((*signal-stop-emission* signal-stop-emission))
- (apply callback args))
+ (let ((*signal-stop-emission*
+ #'(lambda ()
+ (%signal-stop-emission gobject
+ signal-id detail-quark))))
+ (apply callback args))
(when (signal-handler-is-connected-p gobject handler-id)
- (signal-handler-disconnect gobject handler-id))))))
- handler-id))))
+ (signal-handler-disconnect gobject handler-id)))))))
+ handler-id))))
;;;; Signal emission
finally
(if return-type
(return
- (with-gvalue (return-value)
+ (with-gvalue (return-value return-type)
(%signal-emitv params signal-id detail return-value)))
(%signal-emitv params signal-id detail (make-pointer 0))))
(loop
;;;; Signal registration
+(defvar *registered-signals* ())
+
(defbinding %signal-newv (name itype flags return-type param-types)
unsigned-int
((signal-name-to-string name) string)
(defun signal-new (name itype flags return-type param-types)
(when (zerop (signal-lookup name itype))
+ (push (list name itype flags return-type param-types) *registered-signals*)
(%signal-newv name itype flags return-type param-types)))
+(defun reinitialize-signals ()
+ (mapc #'(lambda (args) (apply #'%signal-newv args)) *registered-signals*))
+
+(asdf:install-init-hook 'reinitialize-signals)
+(asdf:install-init-hook 'reinitialize-signal-override-class-closures)
+
;;;; Convenient macros
(defmacro define-callback-marshal (name return-type args &key (callback-id :last))