[perl-Glib-Object-Introspection] Add support for an args converter for signal marshalling

[Torsten SchÃnfeld <tsch src gnome org>]

commit 19ffd86bd24e7544ea30d2bd9ecb456239e54183
Author: Torsten SchÃnfeld <kaffeetisch gmx de>
Date:   Tue Jan 8 22:37:39 2013 +0100

    Add support for an args converter for signal marshalling
    
    This allows bindings to specify a code reference that is invoked with the
    arguments intended for a signal handler; whatever it returns is then passed on
    instead.

 GObjectIntrospection.xs          |   20 ++++++++++++++++----
 gperl-i11n-callback.c            |    5 +++--
 gperl-i11n-invoke-perl.c         |   35 ++++++++++++++++++++++++++++++++---
 lib/Glib/Object/Introspection.pm |    8 +++++---
 4 files changed, 56 insertions(+), 12 deletions(-)
---
diff --git a/GObjectIntrospection.xs b/GObjectIntrospection.xs
index c3af594..f558669 100644
--- a/GObjectIntrospection.xs
+++ b/GObjectIntrospection.xs
@@ -48,7 +48,9 @@ typedef struct {
 	/* ... or a sub name to be called as a method on the invocant. */
 	gchar *sub_name;
 
+	/* these are currently only used for signal handler invocation. */
 	gboolean swap_data;
+	SV *args_converter;
 
 	guint data_pos;
 	guint destroy_pos;
@@ -59,6 +61,11 @@ typedef struct {
 } GPerlI11nPerlCallbackInfo;
 
 typedef struct {
+	GISignalInfo *interface;
+	SV *args_converter;
+} GPerlI11nPerlSignalInfo;
+
+typedef struct {
 	GICallableInfo *interface;
 
 	gpointer func;
@@ -786,11 +793,12 @@ _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)
+_use_generic_signal_marshaller_for (class, const gchar *package, const gchar *signal, SV *args_converter=NULL)
     PREINIT:
 	GType gtype;
 	GIRepository *repository;
-	GIBaseInfo *container_info, *signal_info = NULL;
+	GIBaseInfo *container_info;
+	GPerlI11nPerlSignalInfo *signal_info;
 	ffi_cif *cif;
 	ffi_closure *closure;
 	GIBaseInfo *closure_marshal_info;
@@ -808,7 +816,9 @@ _use_generic_signal_marshaller_for (class, const gchar *package, const gchar *si
 		croak ("Could not find object/interface info for package %s",
 		       package);
 
-	signal_info = get_signal_info (container_info, signal);
+	signal_info = g_new0 (GPerlI11nPerlSignalInfo, 1); // FIXME: ctor?
+	signal_info->interface = get_signal_info (container_info, signal);
+	signal_info->args_converter = SvREFCNT_inc (args_converter);
 	if (!signal_info)
 		croak ("Could not find signal %s for package %s",
 		       signal, package);
@@ -835,7 +845,9 @@ _use_generic_signal_marshaller_for (class, const gchar *package, const gchar *si
 	 *
 	 * g_callable_info_free_closure (signal_info, closure);
 	 * g_free (cif);
-	 * g_base_info_unref (signal_info);
+	 * g_base_info_unref (signal_info->interface);
+	 * SvREFCNT_dec (signal_info->args_converter);
+	 * g_free (signal_info);
 	 */
 
 	g_base_info_unref (container_info);
diff --git a/gperl-i11n-callback.c b/gperl-i11n-callback.c
index 797d5d9..92e537e 100644
--- a/gperl-i11n-callback.c
+++ b/gperl-i11n-callback.c
@@ -19,9 +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. */
+	/* These are only relevant for signal marshalling; if needed, they get
+	 * set in invoke_perl_signal_handler. */
 	info->swap_data = FALSE;
+	info->args_converter = NULL;
 
 #ifdef PERL_IMPLICIT_CONTEXT
 	info->priv = aTHX;
diff --git a/gperl-i11n-invoke-perl.c b/gperl-i11n-invoke-perl.c
index 02df5b4..97422ff 100644
--- a/gperl-i11n-invoke-perl.c
+++ b/gperl-i11n-invoke-perl.c
@@ -11,6 +11,7 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
 	guint n_return_values, n_returned;
 	I32 context;
 	SV *instance_sv = NULL, *data_sv = NULL, *first_sv = NULL, *last_sv = NULL;
+	SV *args_converter;
 	dGPERL_CALLBACK_MARSHAL_SP;
 
 	PERL_UNUSED_VAR (cif);
@@ -29,6 +30,20 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
 
 	PUSHMARK (SP);
 
+	args_converter = info->args_converter;
+	if (args_converter) {
+		/* if we are given an args converter, we will call it directly
+		 * after we pushed the original args onto the stack.  we then
+		 * want to invoke the Perl code with whatever the args
+		 * converter returned.  to achieve this, we do a double
+		 * PUSHMARK, which puts on the markstack two pointers to the
+		 * same place on the stack.  after the args converter returns,
+		 * the markstack pointer is decremented, and the invocation of
+		 * the normal Perl code then sees the other entry we put on the
+		 * markstack. */
+		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 */
@@ -122,6 +137,15 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
 
 	PUTBACK;
 
+	/* invoke the args converter with the original args on the stack.
+	 * since we created two identical entries on the markstack, the
+	 * call_method or call_sv below will invoke the Perl code with whatever
+	 * the args converter returned. */
+	if (args_converter) {
+		call_sv (args_converter, G_ARRAY);
+		SPAGAIN;
+	}
+
 	/* determine suitable Perl call context */
 	context = G_VOID | G_DISCARD;
 	if (iinfo.has_return_value) {
@@ -264,7 +288,7 @@ invoke_perl_signal_handler (ffi_cif* cif, gpointer resp, gpointer* args, gpointe
 	gpointer invocation_hint = CAST_RAW (args[4], gpointer);
 	gpointer marshal_data = CAST_RAW (args[5], gpointer);
 
-	GIBaseInfo *signal_info = userdata;
+	GPerlI11nPerlSignalInfo *signal_info = userdata;
 
 	GPerlClosure *perl_closure = (GPerlClosure *) closure;
 	GPerlI11nPerlCallbackInfo *cb_info;
@@ -275,14 +299,19 @@ invoke_perl_signal_handler (ffi_cif* cif, gpointer resp, gpointer* args, gpointe
 	PERL_UNUSED_VAR (marshal_data);
 
 	dwarn ("invoke_perl_signal_handler: n args %d\n",
-	       g_callable_info_get_n_args (signal_info));
+	       g_callable_info_get_n_args (signal_info->interface));
 
-	cb_info = create_perl_callback_closure (signal_info, perl_closure->callback);
+	cb_info = create_perl_callback_closure (signal_info->interface,
+	                                        perl_closure->callback);
 	attach_perl_callback_data (cb_info, perl_closure->data);
 	cb_info->swap_data = GPERL_CLOSURE_SWAP_DATA (perl_closure);
+	cb_info->args_converter = SvREFCNT_inc (signal_info->args_converter);
 
 	c_closure.closure = *closure;
 	c_closure.callback = cb_info->closure;
+	/* If marshal_data is non-NULL, gi_cclosure_marshal_generic uses it as
+	 * the callback.  Hence we pass NULL so that c_closure.callback is
+	 * used. */
 	gi_cclosure_marshal_generic ((GClosure *) &c_closure,
 	                             return_value,
 	                             n_param_values, param_values,
diff --git a/lib/Glib/Object/Introspection.pm b/lib/Glib/Object/Introspection.pm
index 90d51a2..2f1cdbd 100644
--- a/lib/Glib/Object/Introspection.pm
+++ b/lib/Glib/Object/Introspection.pm
@@ -347,11 +347,13 @@ 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], ... ]
+=item use_generic_signal_marshaller_for => [ [package1, signal1, [arg_converter1]], ... ]
 
 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.
+of type C<package1>.  If given, use the code reference C<arg_converter1> to
+convert the arguments that are passed to the signal handler.  In contrast to
+L<Glib>'s normal signal marshaller, the generic signal marshaller supports,
+among other things, pointer arrays and out arguments.
 
 =item reblessers => { package => \&reblesser, ... }