glib/gobject.signals.lisp

   1 (in-package :gobject)
   2
   3 (defcfun g-signal-connect-closure :ulong
   4   (instance :pointer)
   5   (detailed-signal :string)
   6   (closure (:pointer g-closure))
   7   (after :boolean))
   8
   9 (defcfun g-signal-emitv :void
  10   (instance-and-params (:pointer g-value))
  11   (signal-id :uint)
  12   (detail g-quark)
  13   (return-value (:pointer g-value)))
  14
  15 (defcfun g-signal-lookup :uint
  16   (name :string)
  17   (type g-type))
  18
  19 (defbitfield g-signal-flags
  20   :run-first :run-last :run-cleanup :no-recurse :detailed :action :no-hooks)
  21
  22 (defcstruct g-signal-query
  23   (signal-id :uint)
  24   (signal-name :string)
  25   (owner-type g-type)
  26   (signal-flags g-signal-flags)
  27   (return-type g-type)
  28   (n-params :uint)
  29   (param-types (:pointer g-type)))
  30
  31 (defcfun g-signal-query :void
  32   (signal-id :uint)
  33   (query (:pointer g-signal-query)))
  34
  35 (defun unmangle-type (type)
  36   (logxor type (ldb (byte 1 0) type)));;subtract the G_SIGNAL_TYPE_STATIC_SCOPE
  37
  38 (defun emit-signal (object signal-name &rest args)
  39   "Emits the signal.
  40 @arg[object]{an instance of @class{g-object}. Signal is emitted on this object}
  41 @arg[signal-name]{a string specifying the signal}
  42 @arg[args]{arguments for the signal}
  43 @return{none}"
  44   (let ((signal-id (g-signal-lookup signal-name (g-type-from-object (pointer object)))))
  45     (when (= signal-id 0)
  46       (error "Signal ~A not found on object ~A" signal-name object))
  47     (with-foreign-object (q 'g-signal-query)
  48       (g-signal-query signal-id q)
  49       (with-foreign-object (params 'g-value (+ 1 (foreign-slot-value q 'g-signal-query 'n-params)))
  50         (set-g-value (mem-aref params 'g-value 0) object (g-type-from-object (pointer object)) :zero-g-value t)
  51         (iter (for i from 0 below (foreign-slot-value q 'g-signal-query 'n-params))
  52               (for arg in args)
  53               (for type = (unmangle-type (mem-aref (foreign-slot-value q 'g-signal-query 'param-types) 'g-type i)))
  54               (set-g-value (mem-aref params 'g-value (1+ i)) arg type :zero-g-value t))
  55         (prog1
  56             (if (= (foreign-slot-value q 'g-signal-query 'return-type) +g-type-void+)
  57                 (g-signal-emitv params signal-id signal-name (null-pointer))
  58                 (with-foreign-object (return-value 'g-value)
  59                   (g-value-zero return-value)
  60                   (g-value-init return-value (foreign-slot-value q 'g-signal-query 'return-type))
  61                   (prog1 (parse-gvalue return-value)
  62                     (g-value-unset return-value))))
  63           (iter (for i from 0 below (foreign-slot-value q 'g-signal-query 'n-params))
  64                 (g-value-unset (mem-aref params 'g-value (1+ i)))))))))