[perl-Glib-Object-Introspection] Add support for implementing interfaces

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

commit 01084a2c851c5f4283369a0603e9681685d6c2a6
Author: Torsten SchÃnfeld <kaffeetisch gmx de>
Date:   Mon Oct 3 20:10:09 2011 +0200

    Add support for implementing interfaces
    
    This does not cover some exotic corner cases (GtkTreeModel.get_iter, for
    example) whose vfuncs need special treatment.

 GObjectIntrospection.xs          |  167 +++++++++++++++++++++++++++++++++++---
 lib/Glib/Object/Introspection.pm |   10 ++-
 t/interface-implementation.t     |   40 +++++++++
 3 files changed, 204 insertions(+), 13 deletions(-)
---
diff --git a/GObjectIntrospection.xs b/GObjectIntrospection.xs
index 8955afb..cad31a2 100644
--- a/GObjectIntrospection.xs
+++ b/GObjectIntrospection.xs
@@ -87,9 +87,13 @@ typedef struct {
 
 	GICallableInfo *interface;
 
+	/* either we have a code and data pair, ... */
 	SV *code;
 	SV *data;
 
+	/* ... or a sub name to be looked up in the first args' package */
+	gchar *sub_name;
+
 	guint data_pos;
 	guint notify_pos;
 
@@ -1856,6 +1860,7 @@ create_callback_closure (GITypeInfo *cb_type, SV *code)
 	/* FIXME: This should most likely use SvREFCNT_inc instead of
 	 * newSVsv. */
 	info->code = newSVsv (code);
+	info->sub_name = NULL;
 
 #ifdef PERL_IMPLICIT_CONTEXT
 	info->priv = aTHX;
@@ -1870,6 +1875,30 @@ attach_callback_data (GPerlI11nCallbackInfo *info, SV *data)
 	info->data = newSVsv (data);
 }
 
+/* assumes ownership of sub_name */
+static GPerlI11nCallbackInfo *
+create_callback_closure_for_named_sub (GITypeInfo *cb_type, gchar *sub_name)
+{
+	GPerlI11nCallbackInfo *info;
+
+	info = g_new0 (GPerlI11nCallbackInfo, 1);
+	info->interface =
+		(GICallableInfo *) g_type_info_get_interface (cb_type);
+	info->cif = g_new0 (ffi_cif, 1);
+	info->closure =
+		g_callable_info_prepare_closure (info->interface, info->cif,
+		                                 invoke_callback, info);
+	info->sub_name = sub_name;
+	info->code = NULL;
+	info->data = NULL;
+
+#ifdef PERL_IMPLICIT_CONTEXT
+	info->priv = aTHX;
+#endif
+
+	return info;
+}
+
 static void
 invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
 {
@@ -1879,8 +1908,9 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
 	int in_inout;
 	GITypeInfo *return_type;
 	gboolean have_return_type;
-	int n_return_values;
+	int n_return_values, n_returned;
 	I32 context;
+	SV *code_sv;
 	dGPERL_CALLBACK_MARSHAL_SP;
 
 	PERL_UNUSED_VAR (cif);
@@ -1980,19 +2010,40 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
 		}
 	}
 
+	if (info->sub_name) {
+		/* ASSUMPTION: for a named sub, we expect the first argument to
+		 * be an object with a Perl implementation whose package is
+		 * supposed to contain the sub. */
+		GObject *object;
+		HV *stash;
+		GV *slot;
+		object = * (GObject **) args[0];
+		g_assert (G_IS_OBJECT (object));
+		stash = gperl_object_stash_from_type (G_OBJECT_TYPE (object));
+		g_assert (stash);
+		slot = gv_fetchmethod (stash, info->sub_name);
+		if (!slot || !GvCV (slot)) {
+			ccroak ("Could not find a sub called '%s' in package '%s'",
+			        info->sub_name,
+			        gperl_object_package_from_type (G_OBJECT_TYPE (object)));
+		}
+		dwarn ("calling '%s' in '%s'",
+		       info->sub_name,
+		       gperl_object_package_from_type (G_OBJECT_TYPE (object)));
+		code_sv = (SV *) GvCV (slot);
+	} else {
+		code_sv = info->code;
+	}
+
 	/* do the call, demand #in-out+#out+#return-value return values */
 	n_return_values = have_return_type
 	  ? in_inout + 1
 	  : in_inout;
-	if (n_return_values == 0) {
-		call_sv (info->code, context);
-	} else {
-		int n_returned = call_sv (info->code, context);
-		if (n_returned != n_return_values) {
-			ccroak ("callback returned %d values "
-			       "but is supposed to return %d values",
-			       n_returned, n_return_values);
-		}
+	n_returned = call_sv (code_sv, context);
+	if (n_return_values != 0 && n_returned != n_return_values) {
+		ccroak ("callback returned %d values "
+		        "but is supposed to return %d values",
+		        n_returned, n_return_values);
 	}
 
 	SPAGAIN;
@@ -2098,9 +2149,10 @@ release_callback (gpointer data)
 
 	if (info->code)
 		SvREFCNT_dec (info->code);
-
 	if (info->data)
 		SvREFCNT_dec (info->data);
+	if (info->sub_name)
+		g_free (info->sub_name);
 
 	g_free (info);
 }
@@ -2419,6 +2471,66 @@ allocate_out_mem (GITypeInfo *arg_type)
 
 /* ------------------------------------------------------------------------- */
 
+static void
+generic_interface_init (gpointer iface, gpointer data)
+{
+	GIInterfaceInfo *info = data;
+	GIStructInfo *struct_info;
+	gint n, i, n_fields, i_fields;
+	struct_info = g_interface_info_get_iface_struct (info);
+	n_fields = g_struct_info_get_n_fields (struct_info);
+	n = g_interface_info_get_n_vfuncs (info);
+	for (i = 0; i < n; i++) {
+		GIVFuncInfo *vfunc_info;
+		const gchar *vfunc_name;
+		GIFieldInfo *field_info;
+		gint field_offset;
+		GITypeInfo *field_type_info;
+		gchar *perl_method_name;
+		GPerlI11nCallbackInfo *callback_info;
+
+		vfunc_info = g_interface_info_get_vfunc (info, i);
+		vfunc_name = g_base_info_get_name (vfunc_info);
+		/* FIXME: g_vfunc_info_get_offset does not seem to work here. */
+		for (i_fields = 0; i_fields < n_fields; i_fields++) {
+			field_info = g_struct_info_get_field (struct_info, i_fields);
+			if (strEQ (g_base_info_get_name (field_info), vfunc_name))
+			{
+				break;
+			}
+			g_base_info_unref (field_info);
+			field_info = NULL;
+		}
+		g_assert (field_info);
+
+		field_offset = g_field_info_get_offset (field_info);
+		field_type_info = g_field_info_get_type (field_info);
+		perl_method_name = g_ascii_strup (vfunc_name, -1);
+		callback_info = create_callback_closure_for_named_sub (field_type_info, perl_method_name);
+		dwarn ("installing vfunc %s as %s at offset %d (vs. %d) inside %p\n",
+		       vfunc_name, perl_method_name,
+		       field_offset, g_vfunc_info_get_offset (vfunc_info),
+		       iface);
+		G_STRUCT_MEMBER (gpointer, iface, field_offset) = callback_info->closure;
+
+		g_base_info_unref (field_type_info);
+		g_base_info_unref (field_info);
+		g_base_info_unref (vfunc_info);
+	}
+	g_base_info_unref (struct_info);
+}
+
+static void
+generic_interface_finalize (gpointer iface, gpointer data)
+{
+	GIInterfaceInfo *info = data;
+	PERL_UNUSED_VAR (iface);
+	dwarn ("releasing interface info\n");
+	g_base_info_unref ((GIBaseInfo *) info);
+}
+
+/* ------------------------------------------------------------------------- */
+
 MODULE = Glib::Object::Introspection	PACKAGE = Glib::Object::Introspection
 
 void
@@ -2449,6 +2561,7 @@ _register_types (class, namespace, package)
 	AV *global_functions;
 	HV *namespaced_functions;
 	HV *fields;
+	AV *interfaces;
     PPCODE:
 	repository = g_irepository_get_default ();
 
@@ -2456,6 +2569,7 @@ _register_types (class, namespace, package)
 	global_functions = newAV ();
 	namespaced_functions = newHV ();
 	fields = newHV ();
+	interfaces = newAV ();
 
 	number = g_irepository_get_n_infos (repository, namespace);
 	for (i = 0; i < number; i++) {
@@ -2479,6 +2593,10 @@ _register_types (class, namespace, package)
 			av_push (global_functions, newSVpv (name, PL_na));
 		}
 
+		if (info_type == GI_INFO_TYPE_INTERFACE) {
+			av_push (interfaces, newSVpv (name, PL_na));
+		}
+
 		if (info_type != GI_INFO_TYPE_OBJECT &&
 		    info_type != GI_INFO_TYPE_INTERFACE &&
 		    info_type != GI_INFO_TYPE_BOXED &&
@@ -2550,10 +2668,11 @@ _register_types (class, namespace, package)
 	gperl_hv_take_sv (namespaced_functions, "", 0,
 	                  newRV_noinc ((SV *) global_functions));
 
-	EXTEND (SP, 1);
+	EXTEND (SP, 4);
 	PUSHs (sv_2mortal (newRV_noinc ((SV *) namespaced_functions)));
 	PUSHs (sv_2mortal (newRV_noinc ((SV *) constants)));
 	PUSHs (sv_2mortal (newRV_noinc ((SV *) fields)));
+	PUSHs (sv_2mortal (newRV_noinc ((SV *) interfaces)));
 
 SV *
 _fetch_constant (class, basename, constant)
@@ -2651,6 +2770,30 @@ _set_field (class, basename, namespace, field, invocant, new_value)
 	g_base_info_unref (namespace_info);
 
 void
+_add_interface (class, basename, interface_name, target_package)
+	const gchar *basename
+	const gchar *interface_name
+	const gchar *target_package
+    PREINIT:
+	GIRepository *repository;
+	GIInterfaceInfo *info;
+	GInterfaceInfo iface_info;
+	GType gtype;
+    CODE:
+	repository = g_irepository_get_default ();
+	info = g_irepository_find_by_name (repository, basename, interface_name);
+	if (!GI_IS_INTERFACE_INFO (info))
+		ccroak ("not an interface");
+	iface_info.interface_init = generic_interface_init;
+	iface_info.interface_finalize = generic_interface_finalize,
+	iface_info.interface_data = info;
+	gtype = gperl_object_type_from_package (target_package);
+	g_type_add_interface_static (gtype,
+	                             g_registered_type_info_get_g_type (info),
+	                             &iface_info);
+	/* info is unref'd in generic_interface_finalize */
+
+void
 invoke (class, basename, namespace, method, ...)
 	const gchar *basename
 	const gchar_ornull *namespace
diff --git a/lib/Glib/Object/Introspection.pm b/lib/Glib/Object/Introspection.pm
index 91786cc..dddb16b 100644
--- a/lib/Glib/Object/Introspection.pm
+++ b/lib/Glib/Object/Introspection.pm
@@ -73,7 +73,7 @@ sub setup {
 
   __PACKAGE__->_load_library($basename, $version, $search_path);
 
-  my ($functions, $constants, $fields) =
+  my ($functions, $constants, $fields, $interfaces) =
     __PACKAGE__->_register_types($basename, $package);
 
   no strict qw(refs);
@@ -134,6 +134,14 @@ sub setup {
       };
     }
   }
+
+  foreach my $name (@{$interfaces}) {
+    my $adder_name = $package . '::' . $name . '::_ADD_INTERFACE';
+    *{$adder_name} = sub {
+      my ($class, $target_package) = @_;
+      __PACKAGE__->_add_interface($basename, $name, $target_package);
+    };
+  }
 }
 
 1;
diff --git a/t/interface-implementation.t b/t/interface-implementation.t
new file mode 100644
index 0000000..edccce6
--- /dev/null
+++ b/t/interface-implementation.t
@@ -0,0 +1,40 @@
+#!/usr/bin/env perl
+
+BEGIN { require './t/inc/setup.pl' };
+
+use strict;
+use warnings;
+
+plan tests => 4;
+
+{
+  package Foo;
+  use Glib::Object::Subclass
+    'Glib::Object',
+      interfaces => [ 'GI::Interface' ];
+}
+
+{
+  my $foo = Foo->new;
+  local $@;
+  eval { $foo->test_int8_in (23) };
+  like ($@, qr/TEST_INT8_IN/);
+}
+
+{
+  package Bar;
+  use Glib::Object::Subclass
+    'Glib::Object',
+      interfaces => [ 'GI::Interface' ];
+  sub TEST_INT8_IN {
+    my ($self, $int8) = @_;
+    Test::More::isa_ok ($self, 'Bar');
+    Test::More::isa_ok ($self, 'GI::Interface');
+  }
+}
+
+{
+  my $bar = Bar->new;
+  $bar->test_int8_in (23);
+  ok (1);
+}