[perl-Glib-Object-Introspection] Use normal method calling to invoke interface vfuncs

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

commit 3b16ba143f8e66176bc98560edea2383dd5a83a9
Author: Torsten SchÃnfeld <kaffeetisch gmx de>
Date:   Fri Oct 7 19:21:02 2011 +0200

    Use normal method calling to invoke interface vfuncs

 GObjectIntrospection.xs      |   32 ++++----------------------------
 t/interface-implementation.t |   31 +++++++++++++++++++++----------
 2 files changed, 25 insertions(+), 38 deletions(-)
---
diff --git a/GObjectIntrospection.xs b/GObjectIntrospection.xs
index a371692..c66c777 100644
--- a/GObjectIntrospection.xs
+++ b/GObjectIntrospection.xs
@@ -91,7 +91,7 @@ typedef struct {
 	SV *code;
 	SV *data;
 
-	/* ... or a sub name to be looked up in the first args' package */
+	/* ... or a sub name to be called as a method on the invocant */
 	gchar *sub_name;
 
 	guint data_pos;
@@ -1918,7 +1918,6 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
 	gboolean have_return_type;
 	int n_return_values, n_returned;
 	I32 context;
-	SV *code_sv;
 	dGPERL_CALLBACK_MARSHAL_SP;
 
 	PERL_UNUSED_VAR (cif);
@@ -2018,36 +2017,13 @@ 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;
-	n_returned = call_sv (code_sv, context);
+	n_returned = info->sub_name
+		? call_method (info->sub_name, context)
+		: call_sv (info->code, context);
 	if (n_return_values != 0 && n_returned != n_return_values) {
 		ccroak ("callback returned %d values "
 		        "but is supposed to return %d values",
diff --git a/t/interface-implementation.t b/t/interface-implementation.t
index edccce6..499d3f7 100644
--- a/t/interface-implementation.t
+++ b/t/interface-implementation.t
@@ -5,36 +5,47 @@ BEGIN { require './t/inc/setup.pl' };
 use strict;
 use warnings;
 
-plan tests => 4;
+plan tests => 7;
 
 {
-  package Foo;
+  package NoImplementation;
   use Glib::Object::Subclass
     'Glib::Object',
-      interfaces => [ 'GI::Interface' ];
+    interfaces => [ 'GI::Interface' ];
 }
 
 {
-  my $foo = Foo->new;
+  my $foo = NoImplementation->new;
   local $@;
   eval { $foo->test_int8_in (23) };
   like ($@, qr/TEST_INT8_IN/);
 }
 
 {
-  package Bar;
+  package GoodImplementation;
   use Glib::Object::Subclass
     'Glib::Object',
-      interfaces => [ 'GI::Interface' ];
+    interfaces => [ 'GI::Interface' ];
   sub TEST_INT8_IN {
     my ($self, $int8) = @_;
-    Test::More::isa_ok ($self, 'Bar');
+    Test::More::isa_ok ($self, __PACKAGE__);
     Test::More::isa_ok ($self, 'GI::Interface');
   }
 }
 
 {
-  my $bar = Bar->new;
-  $bar->test_int8_in (23);
-  ok (1);
+  my $foo = GoodImplementation->new;
+  $foo->test_int8_in (23);
+  pass;
+}
+
+{
+  package InheritedImplementation;
+  use Glib::Object::Subclass 'GoodImplementation';
+}
+
+{
+  my $foo = InheritedImplementation->new;
+  $foo->test_int8_in (23);
+  pass;
 }