glib/gobject.type-info.signals.lisp

   1 (in-package :gobject)
   2
   3 (defstruct signal-info
   4   id
   5   name
   6   owner-type
   7   flags
   8   return-type
   9   param-types
  10   detail)
  11
  12 (defmethod print-object ((instance signal-info) stream)
  13   (if *print-readably*
  14       (call-next-method)
  15       (print-unreadable-object (instance stream)
  16         (format stream
  17                 "Signal [#~A] ~A ~A.~A~@[::~A~](~{~A~^, ~})~@[ [~{~A~^, ~}]~]"
  18                 (signal-info-id instance)
  19                 (gtype-name (signal-info-return-type instance))
  20                 (gtype-name (signal-info-owner-type instance))
  21                 (signal-info-name instance)
  22                 (signal-info-detail instance)
  23                 (mapcar #'gtype-name (signal-info-param-types instance))
  24                 (signal-info-flags instance)))))
  25
  26 (defun query-signal-info (signal-id)
  27   (with-foreign-object (q 'g-signal-query)
  28     (g-signal-query signal-id q)
  29     (assert (not (zerop (foreign-slot-value q 'g-signal-query :signal-id))))
  30     (let ((param-types
  31            (iter (with param-types = (foreign-slot-value q 'g-signal-query :param-types))
  32                  (for i from 0 below (foreign-slot-value q 'g-signal-query :n-params))
  33                  (for param-type = (mem-aref param-types '(g-type-designator :mangled-p t) i))
  34                  (collect param-type))))
  35       (make-signal-info :id signal-id
  36                         :name (foreign-slot-value q 'g-signal-query :signal-name)
  37                         :owner-type (foreign-slot-value q 'g-signal-query :owner-type)
  38                         :flags (foreign-slot-value q 'g-signal-query :signal-flags)
  39                         :return-type (foreign-slot-value q 'g-signal-query :return-type)
  40                         :param-types param-types))))
  41
  42 (defun parse-signal-name (owner-type signal-name)
  43   (with-foreign-objects ((signal-id :uint) (detail 'glib:g-quark))
  44     (when (g-signal-parse-name signal-name owner-type signal-id detail t)
  45       (let ((signal-info (query-signal-info (mem-ref signal-id :uint))))
  46         (setf (signal-info-detail signal-info) (mem-ref detail 'g-quark))
  47         signal-info))))
  48
  49 (defun type-signals (type &key include-inherited)
  50   (unless (g-type= type +g-type-invalid+)
  51     (let ((signals (with-foreign-object (n-ids :uint)
  52                      (with-unwind (ids (g-signal-list-ids type n-ids) g-free)
  53                        (iter (for i from 0 below (mem-ref n-ids :uint))
  54                              (collect (query-signal-info (mem-aref ids :uint i))))))))
  55       (if include-inherited
  56           (nconc (type-signals (g-type-parent type) :include-inherited t)
  57                  (iter (for interface in (g-type-interfaces type))
  58                        (nconcing (type-signals interface :include-inherited t)))
  59                  signals)
  60           signals))))