From db0d829452f27bbef68da2afd755b7accc5be5be Mon Sep 17 00:00:00 2001 From: Dmitry Kalyanov Date: Sun, 12 Jul 2009 13:21:57 +0400 Subject: [PATCH] Support for mangled GTypes in g-type-designator foreign type; conversion g-type-designators to string and numeric; added parsing and querying signals; --- glib/gobject.ffi.lisp | 15 +++++++-- glib/gobject.ffi.package.lisp | 6 +++- glib/gobject.signals.lisp | 5 +-- glib/gobject.type-designator.lisp | 24 +++++++++++++-- glib/gobject.type-info.lisp | 13 +++++++- glib/gobject.type-info.object.lisp | 59 ++++++++++++++++++++++++++++++++++++ 6 files changed, 112 insertions(+), 10 deletions(-) diff --git a/glib/gobject.ffi.lisp b/glib/gobject.ffi.lisp index 3a31969..fab0916 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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)))) -- 1.7.10.4