Support for mangled GTypes in g-type-designator foreign type; conversion g-type-desig...

signals;

diff --git a/glib/gobject.ffi.lisp b/glib/gobject.ffi.lisp
index 3a31969..fab0916 100644 (file)
--- a/glib/gobject.ffi.lisp
+++ b/glib/gobject.ffi.lisp
@@ -966,14 +966,25 @@ Example:
   (:signal-name :string)
   (:owner-type g-type-designator)
   (:signal-flags g-signal-flags)
-  (:return-type g-type-designator)
+  (:return-type (g-type-designator :mangled-p t))
   (:n-params :uint)
-  (:param-types (:pointer g-type)))
+  (:param-types (:pointer (g-type-designator :mangled-p t))))
 
 (defcfun g-signal-query :void
   (signal-id :uint)
   (query (:pointer g-signal-query)))
 
+(defcfun g-signal-list-ids (:pointer :uint)
+  (type g-type-designator)
+  (n-ids (:pointer :uint)))
+
+(defcfun g-signal-parse-name :boolean
+  (detailed-signal :string)
+  (owner-type g-type-designator)
+  (signal-id-ptr (:pointer :uint))
+  (detail-ptr (:pointer g-quark))
+  (force-detail-quark :boolean))
+
 (defcstruct lisp-closure
   (:parent-instance g-closure)
   (:function-id :pointer))

diff --git a/glib/gobject.ffi.package.lisp b/glib/gobject.ffi.package.lisp
index bc8c29b..fd28c63 100644 (file)
--- a/glib/gobject.ffi.package.lisp
+++ b/glib/gobject.ffi.package.lisp
@@ -193,4 +193,8 @@
            #:g-signal-query
            #:g-signal-query
            #:lisp-closure
-           #:g-object-struct))
+           #:g-object-struct
+           #:g-signal-list-ids
+           #:g-type-string
+           #:g-type-numeric
+           #:g-signal-parse-name))

diff --git a/glib/gobject.signals.lisp b/glib/gobject.signals.lisp
index 99fe636..4efa669 100644 (file)
--- a/glib/gobject.signals.lisp
+++ b/glib/gobject.signals.lisp
@@ -1,8 +1,5 @@
 (in-package :gobject)
 
-(defun unmangle-type (type)
-  (logxor type (ldb (byte 1 0) type)));;subtract the G_SIGNAL_TYPE_STATIC_SCOPE
-
 (defun emit-signal (object signal-name &rest args)
   "Emits the signal.
 @arg[object]{an instance of @class{g-object}. Signal is emitted on this object}
@@ -18,7 +15,7 @@
         (set-g-value (mem-aref params 'g-value 0) object (g-type-from-object (pointer object)) :zero-g-value t)
         (iter (for i from 0 below (foreign-slot-value q 'g-signal-query :n-params))
               (for arg in args)
-              (for type = (unmangle-type (mem-aref (foreign-slot-value q 'g-signal-query :param-types) 'g-type i)))
+              (for type = (mem-aref (foreign-slot-value q 'g-signal-query :param-types) '(g-type-designator :mangled-p t) i))
               (set-g-value (mem-aref params 'g-value (1+ i)) arg type :zero-g-value t))
         (prog1
             (if (= (foreign-slot-value q 'g-signal-query :return-type) +g-type-void+)

diff --git a/glib/gobject.type-designator.lisp b/glib/gobject.type-designator.lisp
index 7cf8bf7..a4b2bdf 100644 (file)
--- a/glib/gobject.type-designator.lisp
+++ b/glib/gobject.type-designator.lisp
@@ -3,15 +3,23 @@
 (defctype g-type gsize)
 
 (define-foreign-type g-type-designator ()
-  ()
+  ((mangled-p :initarg :mangled-p
+              :reader g-type-designator-mangled-p
+              :initform nil
+              :documentation "Whether the type designator is mangled with G_SIGNAL_TYPE_STATIC_SCOPE flag"))
   (:documentation "Values of this CFFI foreign type identify the GType. GType is designated by a its name (a string) or a numeric identifier. Functions accept GType designators as a string or integer and return them as a string. Functions @fun{g-type-name} and @fun{g-type-from-name} are used to convert between name and numeric identifier.
 
 Numeric identifier of GType may be different between different program runs. But string identifier of GType does not change.")
   (:actual-type g-type)
   (:simple-parser g-type-designator))
 
+(defun unmangle-g-type (g-type)
+  (logxor g-type (ldb (byte 1 0) g-type)));;subtract the G_SIGNAL_TYPE_STATIC_SCOPE
+
 (defmethod translate-from-foreign (value (type g-type-designator))
-  (g-type-name value))
+  (g-type-name (if (g-type-designator-mangled-p type)
+                   (unmangle-g-type value)
+                   value)))
 
 (defmethod translate-to-foreign (value (type g-type-designator))
   (etypecase value
@@ -19,6 +27,18 @@ Numeric identifier of GType may be different between different program runs. But
     (integer value)
     (null 0)))
 
+(defun g-type-numeric (g-type-designator)
+  (etypecase g-type-designator
+    (string (g-type-from-name g-type-designator))
+    (integer g-type-designator)
+    (null 0)))
+
+(defun g-type-string (g-type-designator)
+  (etypecase g-type-designator
+    (string g-type-designator)
+    (integer (g-type-name g-type-designator))
+    (null nil)))
+
 (defcfun (g-type-name "g_type_name") :string
   "Returns the name of a GType.@see{g-type-from-name}
 

diff --git a/glib/gobject.type-info.lisp b/glib/gobject.type-info.lisp
index 0d21def..3fe91a8 100644 (file)
--- a/glib/gobject.type-info.lisp
+++ b/glib/gobject.type-info.lisp
@@ -55,7 +55,18 @@
            #:flags-item-name
            #:flags-item-value
            #:flags-item-nick
-           #:get-flags-items)
+           #:get-flags-items
+           #:signal-info
+           #:signal-info-id
+           #:signal-info-name
+           #:signal-info-owner-type
+           #:signal-info-flags
+           #:signal-info-return-type
+           #:signal-info-param-types
+           #:signal-info-detail
+           #:query-signal-info
+           #:type-signals
+           #:parse-signal-name)
   (:documentation
 "This package contains functions for querying the basic type information from GObject type system. For an overview of GObject type system, see @a[http://library.gnome.org/devel/gobject/stable/index.html]{GObject documentation}
 

diff --git a/glib/gobject.type-info.object.lisp b/glib/gobject.type-info.object.lisp
index c76600f..043bd23 100644 (file)
--- a/glib/gobject.type-info.object.lisp
+++ b/glib/gobject.type-info.object.lisp
@@ -177,3 +177,62 @@ See accessor functions:
                      :nick (foreign-slot-value flags-value 'g-flags-value
                                                :nick)))
       (g-type-class-unref g-class))))
+
+(defstruct signal-info
+  id
+  name
+  owner-type
+  flags
+  return-type
+  param-types
+  detail)
+
+(defmethod print-object ((instance signal-info) stream)
+  (if *print-readably*
+      (call-next-method)
+      (print-unreadable-object (instance stream)
+        (format stream
+                "Signal [#~A] ~A ~A.~A~@[::~A~](~{~A~^, ~})~@[ [~{~A~^, ~}]~]"
+                (signal-info-id instance)
+                (g-type-string (signal-info-return-type instance))
+                (g-type-string (signal-info-owner-type instance))
+                (signal-info-name instance)
+                (signal-info-detail instance)
+                (mapcar #'g-type-string (signal-info-param-types instance))
+                (signal-info-flags instance)))))
+
+(defun query-signal-info (signal-id)
+  (with-foreign-object (q 'g-signal-query)
+    (g-signal-query signal-id q)
+    (assert (not (zerop (foreign-slot-value q 'g-signal-query :signal-id))))
+    (let ((param-types
+           (iter (with param-types = (foreign-slot-value q 'g-signal-query :param-types))
+                 (for i from 0 below (foreign-slot-value q 'g-signal-query :n-params))
+                 (for param-type = (mem-aref param-types '(g-type-designator :mangled-p t) i))
+                 (collect param-type))))
+      (make-signal-info :id signal-id
+                        :name (foreign-slot-value q 'g-signal-query :signal-name)
+                        :owner-type (foreign-slot-value q 'g-signal-query :owner-type)
+                        :flags (foreign-slot-value q 'g-signal-query :signal-flags)
+                        :return-type (foreign-slot-value q 'g-signal-query :return-type)
+                        :param-types param-types))))
+
+(defun parse-signal-name (owner-type signal-name)
+  (with-foreign-objects ((signal-id :uint) (detail 'glib:g-quark))
+    (when (g-signal-parse-name signal-name owner-type signal-id detail t)
+      (let ((signal-info (query-signal-info (mem-ref signal-id :uint))))
+        (setf (signal-info-detail signal-info) (mem-ref detail 'g-quark))
+        signal-info))))
+
+(defun type-signals (type &key include-inherited)
+  (unless (= (g-type-numeric type) +g-type-invalid+)
+    (let ((signals (with-foreign-object (n-ids :uint)
+                     (with-unwind (ids (g-signal-list-ids type n-ids) g-free)
+                       (iter (for i from 0 below (mem-ref n-ids :uint))
+                             (collect (query-signal-info (mem-aref ids :uint i))))))))
+      (if include-inherited
+          (nconc (type-signals (g-type-parent type) :include-inherited t)
+                 (iter (for interface in (g-type-interfaces type))
+                       (nconcing (type-signals interface :include-inherited t)))
+                 signals)
+          signals))))