GNOME.org
 

[perl-Glib-Object-Introspection] Make generic introspection-based signal marshalling available

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]