glib/gobject.signals.lisp

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