[perl-Glib-Object-Introspection] Put fallback vfuncs into the correct package

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

commit 610766cb140198f96549f54e486fbd4ec33dac0d
Author: Torsten SchÃnfeld <kaffeetisch gmx de>
Date:   Sat Jan 19 19:54:51 2013 +0100

    Put fallback vfuncs into the correct package
    
    Instead of always putting fallback vfuncs into the immediate parent, put them
    into the packages that actually implement them.

 NEWS                             |    1 +
 lib/Glib/Object/Introspection.pm |   53 ++++++++++++++++++++++---------------
 t/vfunc-implementation.t         |   34 ++++++++++++------------
 3 files changed, 49 insertions(+), 39 deletions(-)
---
diff --git a/NEWS b/NEWS
index 4fc3d1c..f56bc90 100644
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,7 @@ Overview of changes in Glib::Object::Introspection <next>
   parameters.
 * Avoid using vfunc names that coincide with special Perl subs.  This fixes
   double-frees occurring for subclasses of Gtk3::Widget.
+* Rework the way fallback vfuncs are installed.
 * Correctly marshal in-out args when invoking Perl code.
 
 Overview of changes in Glib::Object::Introspection 0.013
diff --git a/lib/Glib/Object/Introspection.pm b/lib/Glib/Object/Introspection.pm
index 8da3ea1..e252f42 100644
--- a/lib/Glib/Object/Introspection.pm
+++ b/lib/Glib/Object/Introspection.pm
@@ -168,7 +168,8 @@ sub setup {
     *{$installer_name} = sub {
       my ($target_package) = @_;
       # Delay hooking up the vfuncs until INIT so that we can see whether the
-      # package defines the relevant subs or not.
+      # package defines the relevant subs or not.  FIXME: Shouldn't we only do
+      # the delay dance if ${^GLOBAL_PHASE} eq 'START'?
       push @OBJECT_PACKAGES_WITH_VFUNCS,
            [$basename, $object_name, $target_package];
     };
@@ -195,32 +196,40 @@ sub INIT {
   # would mistake them for an actual implementation.  This would then lead it
   # to put Perl callbacks into the vfunc slots regardless of whether the Perl
   # class in question actually provides implementations.
+  my %implementer_packages_seen;
   foreach my $target (@OBJECT_PACKAGES_WITH_VFUNCS) {
     my ($basename, $object_name, $target_package) = @{$target};
     my @non_perl_parent_packages =
       __PACKAGE__->_find_non_perl_parents($basename, $object_name,
                                           $target_package);
-    my $first_parent = $non_perl_parent_packages[0];
-    foreach my $parent_package (@non_perl_parent_packages) {
-      my @vfuncs = __PACKAGE__->_find_vfuncs_with_implementation(
-                     $parent_package, $first_parent);
-      VFUNC:
-      foreach my $vfunc_names (@vfuncs) {
-        my ($vfunc_name, $perl_vfunc_name) = @{$vfunc_names};
-        if (exists $_FORBIDDEN_SUB_NAMES{$perl_vfunc_name}) {
-          $perl_vfunc_name .= '_VFUNC';
-        }
-        my $full_perl_vfunc_name =
-          $first_parent . '::' . $perl_vfunc_name;
-        if (defined &{$full_perl_vfunc_name}) {
-          next VFUNC;
-        }
-        warn "XXX: $first_parent, $target_package: $full_perl_vfunc_name\n";
-        *{$full_perl_vfunc_name} = sub {
-          __PACKAGE__->_invoke_fallback_vfunc($parent_package,
-                                              $vfunc_name,
-                                              $first_parent,
-                                              @_);
+
+    # For each non-Perl parent, look at all the vfuncs it and its parents
+    # provide.  For each vfunc which has an implementation in the parent
+    # (i.e. the corresponding struct pointer is not NULL), install a fallback
+    # sub which invokes the vfunc implementation.  This assumes that
+    # @non_perl_parent_packages contains the parents in "ancestorial" order,
+    # i.e. the first entry must be the immediate parent.
+    IMPLEMENTER: for (my $i = 0; $i < @non_perl_parent_packages; $i++) {
+      my $implementer_package = $non_perl_parent_packages[$i];
+      next IMPLEMENTER if $implementer_packages_seen{$implementer_package}++;
+      for (my $j = $i; $j < @non_perl_parent_packages; $j++) {
+        my $provider_package = $non_perl_parent_packages[$j];
+        my @vfuncs = __PACKAGE__->_find_vfuncs_with_implementation(
+                       $provider_package, $implementer_package);
+        VFUNC: foreach my $vfunc_names (@vfuncs) {
+          my ($vfunc_name, $perl_vfunc_name) = @{$vfunc_names};
+          if (exists $_FORBIDDEN_SUB_NAMES{$perl_vfunc_name}) {
+            $perl_vfunc_name .= '_VFUNC';
+          }
+          my $full_perl_vfunc_name =
+            $implementer_package . '::' . $perl_vfunc_name;
+          next VFUNC if defined &{$full_perl_vfunc_name};
+          *{$full_perl_vfunc_name} = sub {
+            __PACKAGE__->_invoke_fallback_vfunc($provider_package,
+                                                $vfunc_name,
+                                                $implementer_package,
+                                                @_);
+          }
         }
       }
     }
diff --git a/t/vfunc-implementation.t b/t/vfunc-implementation.t
index 94de845..aa3fbf6 100644
--- a/t/vfunc-implementation.t
+++ b/t/vfunc-implementation.t
@@ -5,7 +5,7 @@ BEGIN { require './t/inc/setup.pl' };
 use strict;
 use warnings;
 
-plan tests => 31;
+plan tests => 34;
 
 {
   package GoodImplementation;
@@ -109,40 +109,40 @@ plan tests => 31;
   is ($foo->get ('int'), 23);
 }
 
-=for segfault
-
 {
-  package NoImplementation;
+  package BadChaininig;
   use Glib::Object::Subclass 'GI::Object';
+  sub METHOD_INT8_IN {
+    my ($self, $int8) = @_;
+    Test::More::isa_ok ($self, __PACKAGE__);
+    Test::More::is ($int8, 23);
+    return $self->SUPER::METHOD_INT8_IN ($int8);
+  }
 }
 
 {
-  my $foo = NoImplementation->new;
+  my $foo = BadChaininig->new;
   local $@;
   eval { $foo->method_int8_in (23) };
-  like ($@, qr/method_int8_in/);
+  like ($@, qr/METHOD_INT8_IN/);
 }
 
-=cut
+=for segfault
 
-=for supported?
+This segfaults currently because the call to method_int8_in tries to invoke the
+corresponding vfunc slot in the class struct for NoImplementation.  But that's
+NULL since NoImplementation doesn't provide an implementation.
 
 {
-  package BadChaininig;
+  package NoImplementation;
   use Glib::Object::Subclass 'GI::Object';
-  sub METHOD_INT8_IN {
-    my ($self, $int8) = @_;
-    Test::More::isa_ok ($self, __PACKAGE__);
-    Test::More::is ($int8, 23);
-    return $self->SUPER::METHOD_INT8_IN ($int8);
-  }
 }
 
 {
-  my $foo = BadChaininig->new;
+  my $foo = NoImplementation->new;
   local $@;
   eval { $foo->method_int8_in (23) };
-  like ($@, qr/method_int8_in/i);
+  like ($@, qr/method_int8_in/);
 }
 
 =cut