[perl-Glib-Object-Introspection] Make generic introspection-based signal marshalling available
- From: Torsten SchÃnfeld <tsch src gnome org>
- To: commits-list gnome org
- Cc:
- Subject: [perl-Glib-Object-Introspection] Make generic introspection-based signal marshalling available
- Date: Tue, 8 Jan 2013 21:41:13 +0000 (UTC)
commit 152df8155361a1fea5127322f50d5fa3d1767333
Author: Torsten SchÃnfeld <kaffeetisch gmx de>
Date: Sat Aug 25 16:45:31 2012 +0200
Make generic introspection-based signal marshalling available
For signals specified via the "use_generic_signal_marshaller_for" import
argument, use a generic introspection-based signal marshaller that is able to
handle things like pointer arrays or out arguments.
GObjectIntrospection.xs | 81 ++++++++++++++++++++++++++++++++++++++
NEWS | 1 +
gperl-i11n-callback.c | 4 ++
gperl-i11n-info.c | 28 +++++++++++++
gperl-i11n-invoke-info.c | 22 +++++++---
gperl-i11n-invoke-perl.c | 74 +++++++++++++++++++++++++++++++---
gperl-i11n-marshal-interface.c | 48 ++++++++++++++++++++++
gperl-i11n-marshal-raw.c | 2 -
lib/Glib/Object/Introspection.pm | 13 ++++++
9 files changed, 257 insertions(+), 16 deletions(-)
---
diff --git a/GObjectIntrospection.xs b/GObjectIntrospection.xs
index c37d6f5..c3af594 100644
--- a/GObjectIntrospection.xs
+++ b/GObjectIntrospection.xs
@@ -48,6 +48,8 @@ typedef struct {
/* ... or a sub name to be called as a method on the invocant. */
gchar *sub_name;
+ gboolean swap_data;
+
guint data_pos;
guint destroy_pos;
@@ -82,6 +84,7 @@ typedef struct {
gboolean is_function;
gboolean is_vfunc;
gboolean is_callback;
+ gboolean is_signal;
guint n_args;
guint n_invoke_args;
@@ -125,6 +128,13 @@ static void attach_c_callback_data (GPerlI11nCCallbackInfo *info, gpointer data)
static void release_c_callback (gpointer data);
/* invocation */
+#if GI_CHECK_VERSION (1, 33, 10)
+static void invoke_perl_signal_handler (ffi_cif* cif,
+ gpointer resp,
+ gpointer* args,
+ gpointer userdata);
+#endif
+
static void invoke_callback (ffi_cif* cif,
gpointer resp,
gpointer* args,
@@ -157,6 +167,8 @@ static GIFunctionInfo * get_function_info (GIRepository *repository,
const gchar *method);
static GIFieldInfo * get_field_info (GIBaseInfo *info,
const gchar *field_name);
+static GISignalInfo * get_signal_info (GIBaseInfo *container_info,
+ const gchar *signal_name);
static GType get_gtype (GIRegisteredTypeInfo *info);
static const gchar * get_package_for_basename (const gchar *basename);
static gboolean is_forbidden_sub_name (const gchar *name);
@@ -174,6 +186,7 @@ static void sv_to_interface (GIArgInfo * arg_info,
GIArgument * arg,
GPerlI11nInvocationInfo * invocation_info);
+static SV * instance_pointer_to_sv (GICallableInfo *info, gpointer pointer);
static gpointer instance_sv_to_pointer (GICallableInfo *info, SV *sv);
static void sv_to_arg (SV * sv,
@@ -206,6 +219,7 @@ static gpointer sv_to_glist (GITransfer transfer, GITypeInfo * type_info, SV * s
static SV * ghash_to_sv (GITypeInfo *info, gpointer pointer, GITransfer transfer);
static gpointer sv_to_ghash (GITransfer transfer, GITypeInfo *type_info, SV *sv);
+#define CAST_RAW(raw, type) (*((type *) raw))
static void raw_to_arg (gpointer raw, GIArgument *arg, GITypeInfo *info);
static void arg_to_raw (GIArgument *arg, gpointer raw, GITypeInfo *info);
@@ -772,6 +786,73 @@ _invoke_fallback_vfunc (class, vfunc_package, vfunc_name, target_package, ...)
g_base_info_unref (info);
void
+_use_generic_signal_marshaller_for (class, const gchar *package, const gchar *signal)
+ PREINIT:
+ GType gtype;
+ GIRepository *repository;
+ GIBaseInfo *container_info, *signal_info = NULL;
+ ffi_cif *cif;
+ ffi_closure *closure;
+ GIBaseInfo *closure_marshal_info;
+ CODE:
+#if GI_CHECK_VERSION (1, 33, 10)
+ gtype = gperl_type_from_package (package);
+ if (!gtype)
+ croak ("Could not find GType for package %s", package);
+
+ repository = g_irepository_get_default ();
+ container_info = g_irepository_find_by_gtype (repository, gtype);
+ if (!container_info ||
+ !(GI_IS_OBJECT_INFO (container_info) ||
+ GI_IS_INTERFACE_INFO (container_info)))
+ croak ("Could not find object/interface info for package %s",
+ package);
+
+ signal_info = get_signal_info (container_info, signal);
+ if (!signal_info)
+ croak ("Could not find signal %s for package %s",
+ signal, package);
+
+ closure_marshal_info = g_irepository_find_by_name (repository,
+ "GObject",
+ "ClosureMarshal");
+ g_assert (closure_marshal_info);
+ cif = g_new0 (ffi_cif, 1);
+ closure = g_callable_info_prepare_closure (closure_marshal_info,
+ cif,
+ invoke_perl_signal_handler,
+ signal_info);
+ g_base_info_unref (closure_marshal_info);
+
+ dwarn ("_use_generic_signal_marshaller_for: "
+ "package %s, signal %s => closure %p\n",
+ package, signal, closure);
+ gperl_signal_set_marshaller_for (gtype, (gchar*) signal, (GClosureMarshal) closure);
+
+ /* These should be freed when the signal marshaller is not needed
+ * anymore. But gperl_signal_set_marshaller_for does not provide a
+ * hook for resource freeing.
+ *
+ * g_callable_info_free_closure (signal_info, closure);
+ * g_free (cif);
+ * g_base_info_unref (signal_info);
+ */
+
+ g_base_info_unref (container_info);
+#else
+ /* g_callable_info_prepare_closure, and thus
+ * create_perl_callback_closure and invoke_perl_signal_handler, did not
+ * work correctly for signals prior to commit
+ * d8970fbc500a8b20853b564536251315587450d9 in
+ * gobject-introspection. */
+ warn ("*** Cannot use generic signal marshallers for signal %s of %s "
+ "unless gobject-introspection >= 1.33.10; "
+ "any handlers connected to the signal "
+ "might thus be invoked incorrectly",
+ signal, package);
+#endif
+
+void
invoke (class, basename, namespace, method, ...)
const gchar *basename
const gchar_ornull *namespace
diff --git a/NEWS b/NEWS
index 028737a..5cf92fb 100644
--- a/NEWS
+++ b/NEWS
@@ -1,6 +1,7 @@
Overview of changes in Glib::Object::Introspection <next>
========================================================
+* Implement generic signal marshalling.
* Avoid using vfunc names that coincide with special Perl subs. This fixes
double-frees occurring for subclasses of Gtk3::Widget.
* Correctly marshal in-out args when invoking Perl code.
diff --git a/gperl-i11n-callback.c b/gperl-i11n-callback.c
index 7f0f3fa..797d5d9 100644
--- a/gperl-i11n-callback.c
+++ b/gperl-i11n-callback.c
@@ -19,6 +19,10 @@ create_perl_callback_closure (GICallableInfo *cb_info, SV *code)
info->code = newSVsv (code);
info->sub_name = NULL;
+ /* This is only relevant for signal marshalling; if needed, it gets set
+ * in invoke_perl_signal_handler. */
+ info->swap_data = FALSE;
+
#ifdef PERL_IMPLICIT_CONTEXT
info->priv = aTHX;
#endif
diff --git a/gperl-i11n-info.c b/gperl-i11n-info.c
index b61cf43..a5fc14a 100644
--- a/gperl-i11n-info.c
+++ b/gperl-i11n-info.c
@@ -112,6 +112,34 @@ get_field_info (GIBaseInfo *info, const gchar *field_name)
return NULL;
}
+/* Caller owns return value */
+static GISignalInfo *
+get_signal_info (GIBaseInfo *container_info, const gchar *signal_name)
+{
+ if (GI_IS_OBJECT_INFO (container_info)) {
+ return g_object_info_find_signal (container_info, signal_name);
+ } else if (GI_IS_INTERFACE_INFO (container_info)) {
+#if GI_CHECK_VERSION (1, 35, 4)
+ return g_interface_info_find_signal (container_info, signal_name);
+#else
+{
+ gint n_signals;
+ gint i;
+ n_signals = g_interface_info_get_n_signals (container_info);
+ for (i = 0; i < n_signals; i++) {
+ GISignalInfo *siginfo =
+ g_interface_info_get_signal (container_info, i);
+ if (strEQ (g_base_info_get_name (siginfo), signal_name))
+ return siginfo;
+ g_base_info_unref (siginfo);
+ }
+ return NULL;
+}
+#endif
+ }
+ return NULL;
+}
+
static GType
get_gtype (GIRegisteredTypeInfo *info)
{
diff --git a/gperl-i11n-invoke-info.c b/gperl-i11n-invoke-info.c
index dcbff8e..c0e7693 100644
--- a/gperl-i11n-invoke-info.c
+++ b/gperl-i11n-invoke-info.c
@@ -176,11 +176,6 @@ static void
prepare_perl_invocation_info (GPerlI11nInvocationInfo *iinfo,
GICallableInfo *info)
{
- /* when invoking Perl code, we currently always use a complete
- * description of the callable (from a record field or some callback
- * typedef). this implies that there is no implicit invocant; it
- * always appears explicitly in the arg list. */
-
dwarn ("Perl invoke: %s\n"
" n_args: %d\n",
g_base_info_get_name (info),
@@ -188,11 +183,24 @@ prepare_perl_invocation_info (GPerlI11nInvocationInfo *iinfo,
iinfo->interface = info;
+ /* When invoking Perl code, we currently always use a complete
+ * description of the callable (from a record field or some callback
+ * typedef) for functions, vfuncs and calllbacks. This implies that
+ * there is no implicit invocant; it always appears explicitly in the
+ * arg list. For signals, however, the invocant is implicit. */
iinfo->is_function = GI_IS_FUNCTION_INFO (info);
iinfo->is_vfunc = GI_IS_VFUNC_INFO (info);
+ iinfo->is_signal = GI_IS_SIGNAL_INFO (info);
iinfo->is_callback = (g_base_info_get_type (info) == GI_INFO_TYPE_CALLBACK);
- dwarn (" is_function = %d, is_vfunc = %d, is_callback = %d\n",
- iinfo->is_function, iinfo->is_vfunc, iinfo->is_callback);
+ dwarn (" is_function = %d, is_vfunc = %d, is_callback = %d, is_signal = %d\n",
+ iinfo->is_function, iinfo->is_vfunc, iinfo->is_callback, iinfo->is_signal);
+ if (iinfo->is_signal) {
+ /* FIXME: Need separate iinfo struct for calls into perl, with
+ * a field "has_implicit_invocant". */
+ iinfo->is_method = TRUE;
+ } else {
+ iinfo->is_method = FALSE;
+ }
iinfo->n_args = g_callable_info_get_n_args (info);
diff --git a/gperl-i11n-invoke-perl.c b/gperl-i11n-invoke-perl.c
index c8747c1..02df5b4 100644
--- a/gperl-i11n-invoke-perl.c
+++ b/gperl-i11n-invoke-perl.c
@@ -6,10 +6,11 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
GPerlI11nPerlCallbackInfo *info;
GICallableInfo *cb_interface;
GPerlI11nInvocationInfo iinfo = {0,};
- guint i;
+ guint args_offset = 0, i;
guint in_inout;
guint n_return_values, n_returned;
I32 context;
+ SV *instance_sv = NULL, *data_sv = NULL, *first_sv = NULL, *last_sv = NULL;
dGPERL_CALLBACK_MARSHAL_SP;
PERL_UNUSED_VAR (cif);
@@ -28,6 +29,21 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
PUSHMARK (SP);
+ /* convert the implicit instance argument and push the first SV onto
+ * the stack; depending on the "swap" setting, this might be the
+ * instance or the user data */
+ if (iinfo.is_method) {
+ instance_sv = SAVED_STACK_SV (instance_pointer_to_sv (
+ cb_interface,
+ CAST_RAW (args[0], gpointer)));
+ args_offset = 1;
+ }
+ data_sv = info->data ? SvREFCNT_inc (info->data) : NULL;
+ first_sv = info->swap_data ? data_sv : instance_sv;
+ last_sv = info->swap_data ? instance_sv : data_sv;
+ if (first_sv)
+ XPUSHs (sv_2mortal (first_sv));
+
/* find arguments; use type information from interface to find in and
* in-out args and their types, count in-out and out args, and find
* suitable converters; push in and in-out arguments onto the perl
@@ -79,8 +95,8 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
* to a pointer to a value, so we need to dereference
* it once. */
raw = direction == GI_DIRECTION_INOUT
- ? *((gpointer *) args[i])
- : args[i];
+ ? *((gpointer *) args[i+args_offset])
+ : args[i+args_offset];
raw_to_arg (raw, &arg, arg_type);
sv = SAVED_STACK_SV (arg_to_sv (&arg, arg_type, transfer, &iinfo));
/* If arg_to_sv returns NULL, we take that as 'skip
@@ -100,9 +116,9 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
g_base_info_unref ((GIBaseInfo *) arg_type);
}
- /* push user data onto the Perl stack */
- if (info->data)
- XPUSHs (sv_2mortal (SvREFCNT_inc (info->data)));
+ /* push the last SV onto the stack; this might be the user data or the instance */
+ if (last_sv)
+ XPUSHs (sv_2mortal (last_sv));
PUTBACK;
@@ -157,7 +173,7 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
GIArgInfo *arg_info = g_callable_info_get_arg (cb_interface, i);
GITypeInfo *arg_type = g_arg_info_get_type (arg_info);
GIDirection direction = g_arg_info_get_direction (arg_info);
- gpointer out_pointer = * (gpointer *) args[i];
+ gpointer out_pointer = * (gpointer *) args[i+args_offset];
if (!out_pointer) {
dwarn ("skipping out arg %d\n", i);
@@ -233,3 +249,47 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
* frees unused ones.
*/
}
+
+/* ------------------------------------------------------------------------- */
+
+#if GI_CHECK_VERSION (1, 33, 10)
+
+static void
+invoke_perl_signal_handler (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
+{
+ GClosure *closure = CAST_RAW (args[0], GClosure*);
+ GValue *return_value = CAST_RAW (args[1], GValue*);
+ guint n_param_values = CAST_RAW (args[2], guint);
+ const GValue *param_values = CAST_RAW (args[3], const GValue*);
+ gpointer invocation_hint = CAST_RAW (args[4], gpointer);
+ gpointer marshal_data = CAST_RAW (args[5], gpointer);
+
+ GIBaseInfo *signal_info = userdata;
+
+ GPerlClosure *perl_closure = (GPerlClosure *) closure;
+ GPerlI11nPerlCallbackInfo *cb_info;
+ GCClosure c_closure;
+
+ PERL_UNUSED_VAR (cif);
+ PERL_UNUSED_VAR (resp);
+ PERL_UNUSED_VAR (marshal_data);
+
+ dwarn ("invoke_perl_signal_handler: n args %d\n",
+ g_callable_info_get_n_args (signal_info));
+
+ cb_info = create_perl_callback_closure (signal_info, perl_closure->callback);
+ attach_perl_callback_data (cb_info, perl_closure->data);
+ cb_info->swap_data = GPERL_CLOSURE_SWAP_DATA (perl_closure);
+
+ c_closure.closure = *closure;
+ c_closure.callback = cb_info->closure;
+ gi_cclosure_marshal_generic ((GClosure *) &c_closure,
+ return_value,
+ n_param_values, param_values,
+ invocation_hint,
+ NULL /* instead of marshal_data */);
+
+ release_perl_callback (cb_info);
+}
+
+#endif
diff --git a/gperl-i11n-marshal-interface.c b/gperl-i11n-marshal-interface.c
index 7c3c852..82ec674 100644
--- a/gperl-i11n-marshal-interface.c
+++ b/gperl-i11n-marshal-interface.c
@@ -48,6 +48,54 @@ instance_sv_to_pointer (GICallableInfo *info, SV *sv)
return pointer;
}
+/* This may call Perl code (via gperl_new_boxed, gperl_sv_from_value,
+ * struct_to_sv), so it needs to be wrapped with PUTBACK/SPAGAIN by the
+ * caller. */
+static SV *
+instance_pointer_to_sv (GICallableInfo *info, gpointer pointer)
+{
+ // We do *not* own container.
+ GIBaseInfo *container = g_base_info_get_container (info);
+ GIInfoType info_type = g_base_info_get_type (container);
+ SV *sv = NULL;
+
+ /* FIXME: Much of this code is duplicated in interface_to_sv. */
+
+ dwarn (" instance_pointer_to_sv: container name: %s, info type: %d\n",
+ g_base_info_get_name (container),
+ info_type);
+
+ switch (info_type) {
+ case GI_INFO_TYPE_OBJECT:
+ case GI_INFO_TYPE_INTERFACE:
+ sv = gperl_new_object (pointer, FALSE);
+ dwarn (" -> object SV: %p\n", sv);
+ break;
+
+ case GI_INFO_TYPE_BOXED:
+ case GI_INFO_TYPE_STRUCT:
+ case GI_INFO_TYPE_UNION:
+ {
+ GType type = get_gtype ((GIRegisteredTypeInfo *) container);
+ if (!type || type == G_TYPE_NONE) {
+ dwarn (" unboxed type\n");
+ sv = struct_to_sv (container, info_type, pointer, FALSE);
+ } else {
+ dwarn (" boxed type: %s (%d)\n",
+ g_type_name (type), type);
+ sv = gperl_new_boxed (pointer, type, FALSE);
+ }
+ warn (" -> boxed pointer: %p\n", pointer);
+ break;
+ }
+
+ default:
+ ccroak ("instance_pointer_to_sv: Don't know how to handle info type %d", info_type);
+ }
+
+ return sv;
+}
+
static void
sv_to_interface (GIArgInfo * arg_info,
GITypeInfo * type_info,
diff --git a/gperl-i11n-marshal-raw.c b/gperl-i11n-marshal-raw.c
index 67e560a..5de0d97 100644
--- a/gperl-i11n-marshal-raw.c
+++ b/gperl-i11n-marshal-raw.c
@@ -1,7 +1,5 @@
/* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */
-#define CAST_RAW(raw, type) (*((type *) raw))
-
static void
raw_to_arg (gpointer raw, GIArgument *arg, GITypeInfo *info)
{
diff --git a/lib/Glib/Object/Introspection.pm b/lib/Glib/Object/Introspection.pm
index 2ec4550..90d51a2 100644
--- a/lib/Glib/Object/Introspection.pm
+++ b/lib/Glib/Object/Introspection.pm
@@ -80,6 +80,9 @@ sub setup {
my %handle_sentinel_boolean_for = exists $params{handle_sentinel_boolean_for}
? map { $_ => 1 } @{$params{handle_sentinel_boolean_for}}
: ();
+ my @use_generic_signal_marshaller_for = exists $params{use_generic_signal_marshaller_for}
+ ? @{$params{use_generic_signal_marshaller_for}}
+ : ();
if (exists $params{reblessers}) {
$_REBLESSERS{$_} = $params{reblessers}->{$_}
@@ -200,6 +203,10 @@ sub setup {
[$basename, $object_name, $target_package];
};
}
+
+ foreach my $packaged_signal (@use_generic_signal_marshaller_for) {
+ __PACKAGE__->_use_generic_signal_marshaller_for (@$packaged_signal);
+ }
}
sub INIT {
@@ -340,6 +347,12 @@ be returned, and otherwise an empty list will be returned.
The function names refer to those after name corrections. Functions occuring
in C<handle_sentinel_boolean_for> may also occur in C<class_static_methods>.
+=item use_generic_signal_marshaller_for => [ [package1, signal1], ... ]
+
+Use an introspection-based generic signal marshaller for the signal C<signal1>
+of type C<package1>. In contrast to the normal signal marshaller, the generic
+marshaller supports, among other things, pointer arrays and out arguments.
+
=item reblessers => { package => \&reblesser, ... }
Tells G:O:I to invoke I<reblesser> whenever a Perl object is created for an
[
Date Prev][
Date Next] [
Thread Prev][
Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]