glib/gobject.type-info.object.lisp

   1 (in-package :gobject.type-info)
   2
   3 (defstruct g-class-property-definition
   4   "Structure describing property of a GObject class.
   5
   6 See accessor functions:
   7 @itemize{
   8 @item{@fun{g-class-property-definition-name}}
   9 @item{@fun{g-class-property-definition-type}}
  10 @item{@fun{g-class-property-definition-readable}}
  11 @item{@fun{g-class-property-definition-writable}}
  12 @item{@fun{g-class-property-definition-constructor}}
  13 @item{@fun{g-class-property-definition-constructor-only}}
  14 @item{@fun{g-class-property-definition-owner-type}}
  15 }
  16 "
  17   name
  18   type
  19   readable
  20   writable
  21   constructor
  22   constructor-only
  23   owner-type)
  24
  25 (defmethod print-object ((instance g-class-property-definition) stream)
  26   (if *print-readably*
  27       (call-next-method)
  28       (print-unreadable-object (instance stream)
  29         (format stream
  30                 "PROPERTY ~A ~A.~A (flags:~@[ readable~]~@[ writable~]~@[ constructor~]~@[ constructor-only~])"
  31                 (g-class-property-definition-type instance)
  32                 (g-class-property-definition-owner-type instance)
  33                 (g-class-property-definition-name instance)
  34                 (g-class-property-definition-readable instance)
  35                 (g-class-property-definition-writable instance)
  36                 (g-class-property-definition-constructor instance)
  37                 (g-class-property-definition-constructor-only instance)))))
  38
  39 (setf (documentation 'g-class-property-definition-name 'function)
  40       "Name of GObject class property. See @class{g-class-property-definition}.
  41 @return{a string}")
  42
  43 (setf (documentation 'g-class-property-definition-type 'function)
  44       "Type of GObject class property. See @class{g-class-property-definition}.
  45 @return{a GType (integer)}")
  46
  47 (setf (documentation 'g-class-property-definition-readable 'function)
  48       "Whether the GObject class property is readable. See @class{g-class-property-definition}.
  49 @return{a boolean}")
  50
  51 (setf (documentation 'g-class-property-definition-writable 'function)
  52       "Whether the GObject class property is writable. See @class{g-class-property-definition}.
  53 @return{a boolean}")
  54
  55 (setf (documentation 'g-class-property-definition-constructor 'function)
  56       "Whether the GObject class property can be set at object construction time. See @class{g-class-property-definition}.
  57 @return{a boolean}")
  58
  59 (setf (documentation 'g-class-property-definition-constructor-only 'function)
  60       "Whether the GObject class property can only be set at object construction time. See @class{g-class-property-definition}.
  61 @return{a boolean}")
  62
  63 (setf (documentation 'g-class-property-definition-owner-type 'function)
  64       "The GType on which this GObject class property was defined. See @class{g-class-property-definition}.
  65 @return{a GType (integer)}")
  66
  67 (defun parse-g-param-spec (param)
  68   (let ((flags (foreign-slot-value param 'g-param-spec :flags)))
  69     (make-g-class-property-definition
  70      :name (foreign-slot-value param 'g-param-spec :name)
  71      :type (foreign-slot-value param 'g-param-spec :value-type)
  72      :readable (not (null (member :readable flags)))
  73      :writable (not (null (member :writable flags)))
  74      :constructor (not (null (member :construct flags)))
  75      :constructor-only (not (null (member :construct-only flags)))
  76      :owner-type (foreign-slot-value param 'g-param-spec :owner-type))))
  77
  78 (defmacro with-unwind ((var expr unwind-function) &body body)
  79   `(let ((,var ,expr))
  80      (unwind-protect (progn ,@body)
  81        (,unwind-function ,var))))
  82
  83 (defun class-properties (g-type)
  84   "@return{list of properties of GObject class @code{g-type}. Each property is described by an object of type @class{g-class-property-definition}.}
  85 @arg[g-type]{an integer or a string specifying the GType}"
  86   (assert (g-type-is-a g-type +g-type-object+))
  87   (with-unwind (g-class (g-type-class-ref g-type) g-type-class-unref)
  88     (with-foreign-object (n-properties :uint)
  89       (with-unwind (params (g-object-class-list-properties g-class n-properties) g-free)
  90         (loop
  91            for i from 0 below (mem-ref n-properties :uint)
  92            for param = (mem-aref params :pointer i)
  93            collect (parse-g-param-spec param))))))
  94
  95 (defun interface-properties (g-type)
  96   "@return{list of properties of GObject interface @code{g-type}. Each property is described by an object of type @class{g-class-property-definition}.}
  97 @arg[g-type]{an integer or a string specifying the GType}"
  98   (assert (g-type-is-a g-type +g-type-interface+))
  99   (with-unwind (g-iface (g-type-default-interface-ref g-type) g-type-default-interface-unref)
 100     (with-foreign-object (n-properties :uint)
 101       (with-unwind (params (g-object-interface-list-properties g-iface n-properties) g-free)
 102         (loop
 103            for i from 0 below (mem-ref n-properties :uint)
 104            for param = (mem-aref params :pointer i)
 105            collect (parse-g-param-spec param))))))
 106
 107 (defstruct enum-item
 108   "A structure describing a single enumeration item.
 109
 110 See accessor functions:
 111 @itemize{
 112 @item{@fun{enum-item-name}}
 113 @item{@fun{enum-item-value}}
 114 @item{@fun{enum-item-nick}}
 115 }"
 116   name value nick)
 117
 118 (setf (documentation 'enum-item-name 'function)
 119       "The C name of enum item, e.g. \"GTK_WINDOW_TOPLEVEL\".
 120 @return{a string}")
 121
 122 (setf (documentation 'enum-item-value 'function)
 123       "The numeric value of enum item.
 124 @return{an integer}")
 125
 126 (setf (documentation 'enum-item-nick 'function)
 127       "The \"nickname\" of enum item. Nickname is a short name of enum item. E.g., \"toplevel\".
 128 @return{a string}")
 129
 130 (defun get-enum-items (type)
 131   "Gets the list of enum items that belong to GEnum type @code{type}
 132 @arg[type]{a string or an integer specifying GEnum type}
 133 @return{a list of @class{enum-item} objects}"
 134   (assert (g-type-is-a type +g-type-enum+))
 135   (let ((g-class (g-type-class-ref type)))
 136     (unwind-protect
 137          (loop
 138             with n = (foreign-slot-value g-class 'g-enum-class :n-values)
 139             with values = (foreign-slot-value g-class 'g-enum-class :values)
 140             for i from 0 below n
 141             for enum-value = (mem-aref values 'g-enum-value i)
 142             collect (make-enum-item
 143                      :name (foreign-slot-value enum-value 'g-enum-value
 144                                                :name)
 145                      :value (foreign-slot-value enum-value 'g-enum-value
 146                                                 :value)
 147                      :nick (foreign-slot-value enum-value 'g-enum-value
 148                                                :nick)))
 149       (g-type-class-unref g-class))))
 150
 151 (defstruct flags-item
 152   "A structure describing a single flags item.
 153
 154 See accessor functions:
 155 @itemize{
 156 @item{@fun{flags-item-name}}
 157 @item{@fun{flags-item-value}}
 158 @item{@fun{flags-item-nick}}
 159 }"
 160   name value nick)
 161
 162 (setf (documentation 'flags-item-name 'function)
 163       "The C name of flags item, e.g. \"GDK_PROPERTY_CHANGE_MASK\".
 164 @return{a string}")
 165
 166 (setf (documentation 'flags-item-value 'function)
 167       "The numeric value of flags item.
 168 @return{an integer}")
 169
 170 (setf (documentation 'flags-item-nick 'function)
 171       "The \"nickname\" of flags item. Nickname is a short name of flags item. E.g., \"property-change-mask\".
 172 @return{a string}")
 173
 174 (defun get-flags-items (type)
 175   "Gets the list of flags items that belong to GFlags type @code{type}
 176 @arg[type]{a string or an integer specifying GFlags type}
 177 @return{a list of @class{flags-item} objects}"
 178   (assert (g-type-is-a type +g-type-flags+))
 179   (let ((g-class (g-type-class-ref type)))
 180     (unwind-protect
 181          (loop
 182             with n = (foreign-slot-value g-class 'g-flags-class :n-values)
 183             with values = (foreign-slot-value g-class 'g-flags-class :values)
 184             for i from 0 below n
 185             for flags-value = (mem-aref values 'g-flags-value i)
 186             collect (make-flags-item
 187                      :name (foreign-slot-value flags-value 'g-flags-value
 188                                                :name)
 189                      :value (foreign-slot-value flags-value 'g-flags-value
 190                                                 :value)
 191                      :nick (foreign-slot-value flags-value 'g-flags-value
 192                                                :nick)))
 193       (g-type-class-unref g-class))))
 194
 195 (defstruct signal-info
 196   id
 197   name
 198   owner-type
 199   flags
 200   return-type
 201   param-types
 202   detail)
 203
 204 (defmethod print-object ((instance signal-info) stream)
 205   (if *print-readably*
 206       (call-next-method)
 207       (print-unreadable-object (instance stream)
 208         (format stream
 209                 "Signal [#~A] ~A ~A.~A~@[::~A~](~{~A~^, ~})~@[ [~{~A~^, ~}]~]"
 210                 (signal-info-id instance)
 211                 (g-type-string (signal-info-return-type instance))
 212                 (g-type-string (signal-info-owner-type instance))
 213                 (signal-info-name instance)
 214                 (signal-info-detail instance)
 215                 (mapcar #'g-type-string (signal-info-param-types instance))
 216                 (signal-info-flags instance)))))
 217
 218 (defun query-signal-info (signal-id)
 219   (with-foreign-object (q 'g-signal-query)
 220     (g-signal-query signal-id q)
 221     (assert (not (zerop (foreign-slot-value q 'g-signal-query :signal-id))))
 222     (let ((param-types
 223            (iter (with param-types = (foreign-slot-value q 'g-signal-query :param-types))
 224                  (for i from 0 below (foreign-slot-value q 'g-signal-query :n-params))
 225                  (for param-type = (mem-aref param-types '(g-type-designator :mangled-p t) i))
 226                  (collect param-type))))
 227       (make-signal-info :id signal-id
 228                         :name (foreign-slot-value q 'g-signal-query :signal-name)
 229                         :owner-type (foreign-slot-value q 'g-signal-query :owner-type)
 230                         :flags (foreign-slot-value q 'g-signal-query :signal-flags)
 231                         :return-type (foreign-slot-value q 'g-signal-query :return-type)
 232                         :param-types param-types))))
 233
 234 (defun parse-signal-name (owner-type signal-name)
 235   (with-foreign-objects ((signal-id :uint) (detail 'glib:g-quark))
 236     (when (g-signal-parse-name signal-name owner-type signal-id detail t)
 237       (let ((signal-info (query-signal-info (mem-ref signal-id :uint))))
 238         (setf (signal-info-detail signal-info) (mem-ref detail 'g-quark))
 239         signal-info))))
 240
 241 (defun type-signals (type &key include-inherited)
 242   (unless (= (g-type-numeric type) +g-type-invalid+)
 243     (let ((signals (with-foreign-object (n-ids :uint)
 244                      (with-unwind (ids (g-signal-list-ids type n-ids) g-free)
 245                        (iter (for i from 0 below (mem-ref n-ids :uint))
 246                              (collect (query-signal-info (mem-aref ids :uint i))))))))
 247       (if include-inherited
 248           (nconc (type-signals (g-type-parent type) :include-inherited t)
 249                  (iter (for interface in (g-type-interfaces type))
 250                        (nconcing (type-signals interface :include-inherited t)))
 251                  signals)
 252           signals))))