From: Peter Rabbitson <ribasushi@cpan.org>
Date: Mon, 18 Mar 2013 07:16:01 +0000 (+0100)
Subject: Fix ton of buggery with defer-immutable accessor shim
X-Git-Tag: v0.10010~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5808b2245979b6d4c0582c10892e8526aa00d673;p=p5sagit%2FClass-Accessor-Grouped.git

Fix ton of buggery with defer-immutable accessor shim
---

diff --git a/Changes b/Changes
index cb14304..3074229 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,12 @@
 Revision history for Class::Accessor::Grouped.
 
+    - Fix bug with identically-named 'simple' accessors in different
+      classes set to access *differently named fields* getting their
+      field access mixed up
+    - Fix subtle pessimization when having identically-named accessors
+      in different classes leads to 'simple' implementations not being
+      replaced by Class::XSAccessor where appropriate
+
 0.10009 2012-11-15 18:51 (UTC)
     - Stop leaking extra methods into the inheritance chain - there
       are plenty already
diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index bc379d7..d392a48 100644
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -786,6 +786,8 @@ my ($accessor_maker_cache, $no_xsa_warned_classes);
 my $original_simple_getter = __PACKAGE__->can ('get_simple');
 my $original_simple_setter = __PACKAGE__->can ('set_simple');
 
+my ($resolved_methods, $cag_produced_crefs);
+
 # Note!!! Unusual signature
 $gen_accessor = sub {
   my ($type, $class, $group, $field, $methname) = @_;
@@ -804,14 +806,10 @@ $gen_accessor = sub {
     die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_ENV__::NO_CXSA )
       if __CAG_ENV__::NO_CXSA;
 
-    my ($expected_cref, $cached_implementation);
-    my $ret = $expected_cref = sub {
+    my $ret = sub {
       my $current_class = length (ref ($_[0] ) ) ? ref ($_[0]) : $_[0];
 
-      # $cached_implementation will be set only if the shim got
-      # 'around'ed, in which case it is handy to avoid re-running
-      # this block over and over again
-      my $resolved_implementation = $cached_implementation->{$current_class} || do {
+      my $resolved_implementation = $resolved_methods->{$current_class}{$methname} ||= do {
         if (
           ($current_class->can('get_simple')||0) == $original_simple_getter
             &&
@@ -857,11 +855,7 @@ $gen_accessor = sub {
       # if after this shim was created someone wrapped it with an 'around',
       # we can not blindly reinstall the method slot - we will destroy the
       # wrapper. Silently chain execution further...
-      if ( !$expected_cref or $expected_cref != ($current_class->can($methname)||0) ) {
-
-        # there is no point in re-determining it on every subsequent call,
-        # just store for future reference
-        $cached_implementation->{$current_class} ||= $resolved_implementation;
+      if ( ! $cag_produced_crefs->{ $current_class->can($methname) || 0 } ) {
 
         # older perls segfault if the cref behind the goto throws
         # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
@@ -870,12 +864,14 @@ $gen_accessor = sub {
         goto $resolved_implementation;
       }
 
+
       if (__CAG_ENV__::TRACK_UNDEFER_FAIL) {
         my $deferred_calls_seen = do {
           no strict 'refs';
           \%{"${current_class}::__cag_deferred_xs_shim_invocations"}
         };
         my @cframe = caller(0);
+
         if (my $already_seen = $deferred_calls_seen->{$cframe[3]}) {
           Carp::carp (
             "Deferred version of method $cframe[3] invoked more than once (originally "
@@ -898,13 +894,16 @@ $gen_accessor = sub {
 
         my $fq_name = "${current_class}::${methname}";
         *$fq_name = Sub::Name::subname($fq_name, $resolved_implementation);
-
-        # need to update what the shim expects too *in case* its
-        # ->can was cached for some moronic reason
-        $expected_cref = $resolved_implementation;
-        Scalar::Util::weaken($expected_cref);
       }
 
+      # now things are installed - one ref less to carry
+      delete $resolved_methods->{$current_class}{$methname};
+
+      # but need to record it in the expectation registry *in case* it
+      # was cached via ->can for some moronic reason
+      Scalar::Util::weaken( $cag_produced_crefs->{$resolved_implementation} = $resolved_implementation );
+
+
       # older perls segfault if the cref behind the goto throws
       # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
       return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
@@ -912,8 +911,9 @@ $gen_accessor = sub {
       goto $resolved_implementation;
     };
 
-    Scalar::Util::weaken($expected_cref); # to break the self-reference
-    $ret;
+    Scalar::Util::weaken($cag_produced_crefs->{$ret} = $ret);
+
+    $ret; # returning shim
   }
 
   # no Sub::Name - just install the coderefs directly (compiling every time)
diff --git a/t/accessors.t b/t/accessors.t
index 8bca250..9a27723 100644
--- a/t/accessors.t
+++ b/t/accessors.t
@@ -1,4 +1,4 @@
-use Test::More tests => 136;
+use Test::More;
 use strict;
 use warnings;
 use lib 't/lib';
@@ -26,7 +26,8 @@ my $test_accessors = {
   runtime_around => {
     # even though this accessor is declared as simple it will *not* be
     # reinstalled due to the runtime 'around'
-    #is_simple => 1,
+    forced_class => 'AccessorGroups',
+    is_simple => 1,
     has_extra => 1,
   },
   multiple1 => {
@@ -45,63 +46,92 @@ my $test_accessors = {
   },
 };
 
-for my $obj (
-  AccessorGroupsSubclass->new,
-) {
+for my $class (qw(
+  AccessorGroupsSubclass
+  AccessorGroups
+  AccessorGroupsParent
+)) {
+  my $obj = $class->new;
+
   for my $name (sort keys %$test_accessors) {
     my $alias = "_${name}_accessor";
     my $field = $test_accessors->{$name}{custom_field} || $name;
     my $extra = $test_accessors->{$name}{has_extra};
+    my $origin_class = 'AccessorGroupsParent';
+
+    if ( $class eq 'AccessorGroupsParent' ) {
+      next if $name eq 'runtime_around';  # implemented in the AG subclass
+      $extra = 0;
+    }
+    elsif ($name eq 'fieldname_torture') {
+      $field = reverse $field;
+      $origin_class = 'AccessorGroups';
+    }
 
     can_ok($obj, $name, $alias);
-    ok(!$obj->can($field))
+    ok(!$obj->can($field), "field for $name is not a method on $class")
       if $field ne $name;
 
+    my $init_shims;
+
     # initial method name
     for my $meth ($name, $alias) {
-      my $cv = svref_2object( $obj->can($meth) );
-      is($cv->GV->NAME, $meth, "initial $meth accessor is named");
+      my $cv = svref_2object( $init_shims->{$meth} = $obj->can($meth) );
+      is($cv->GV->NAME, $meth, "initial ${class}::$meth accessor is named");
       is(
         $cv->GV->STASH->NAME,
-        'AccessorGroups',
-        "initial $meth class correct",
+        $test_accessors->{$name}{forced_class} || $origin_class,
+        "initial ${class}::$meth origin class correct",
       );
     }
 
-    is($obj->$name, undef);
-    is($obj->$alias, undef);
+    is($obj->$name, undef, "${class}::$name begins undef");
+    is($obj->$alias, undef, "${class}::$alias begins undef");
 
     # get/set via name
-    is($obj->$name('a'), 'a');
-    is($obj->$name, 'a');
-    is($obj->{$field}, $extra ? 'a Extra tackled on' : 'a');
+    is($obj->$name('a'), 'a', "${class}::$name setter RV correct");
+    is($obj->$name, 'a', "${class}::$name getter correct");
+    is($obj->{$field}, $extra ? 'a Extra tackled on' : 'a', "${class}::$name corresponding field correct");
 
     # alias gets same as name
-    is($obj->$alias, 'a');
+    is($obj->$alias, 'a', "${class}::$alias getter correct after ${class}::$name setter");
 
     # get/set via alias
-    is($obj->$alias('b'), 'b');
-    is($obj->$alias, 'b');
-    is($obj->{$field}, $extra ? 'b Extra tackled on' : 'b');
+    is($obj->$alias('b'), 'b', "${class}::$alias setter RV correct");
+    is($obj->$alias, 'b', "${class}::$alias getter correct");
+    is($obj->{$field}, $extra ? 'b Extra tackled on' : 'b', "${class}::$alias corresponding field still correct");
 
     # alias gets same as name
-    is($obj->$name, 'b');
+    is($obj->$name, 'b', "${class}::$name getter correct after ${class}::$alias setter");
 
     for my $meth ($name, $alias) {
-      my $cv = svref_2object( $obj->can($meth) );
+      my $resolved = $obj->can($meth);
+
+      my $cv = svref_2object($resolved);
       is($cv->GV->NAME, $meth, "$meth accessor is named after operations");
       is(
         $cv->GV->STASH->NAME,
         # XS deferred subs install into each caller, not into the original parent
-        ($use_xs and $test_accessors->{$name}{is_simple})
-          ? ref $obj
-          : 'AccessorGroups'
-        ,
-        "$meth class correct after operations",
+        $test_accessors->{$name}{forced_class} || (
+          ($use_xs and $test_accessors->{$name}{is_simple})
+            ? (ref $obj)
+            : $origin_class
+        ),
+        "${class}::$meth origin class correct after operations",
       );
+
+      # just simple for now
+      if ($use_xs and $test_accessors->{$name}{is_simple} and ! $test_accessors->{$name}{forced_class}) {
+        ok ($resolved != $init_shims->{$meth}, "$meth was replaced with a resolved version");
+        if ($class eq 'AccessorGroupsParent') {
+          ok ($cv->XSUB, "${class}::$meth is an XSUB");
+        }
+        else {
+          ok (!$cv->XSUB, "${class}::$meth is *not* an XSUB (due to get_simple overrides)");
+        }
+      }
     }
   }
 }
 
-# important
-1;
+done_testing;
diff --git a/t/accessors_pp.t b/t/accessors_pp.t
index cb89232..67f1331 100644
--- a/t/accessors_pp.t
+++ b/t/accessors_pp.t
@@ -27,7 +27,7 @@ for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t clean_namespace.t/)
     my $tfn = catfile($Bin, $tname);
 
     delete $INC{$_} for (
-      qw/AccessorGroups.pm AccessorGroupsRO.pm AccessorGroupsSubclass.pm AccessorGroupsWO.pm/,
+      qw/AccessorGroups.pm AccessorGroupsRO.pm AccessorGroupsSubclass.pm AccessorGroupsParent.pm AccessorGroupsWO.pm/,
       File::Spec::Unix->catfile ($tfn),
     );
 
diff --git a/t/accessors_xs.t b/t/accessors_xs.t
index 12890dd..edb5b48 100644
--- a/t/accessors_xs.t
+++ b/t/accessors_xs.t
@@ -29,7 +29,7 @@ for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t clean_namespace.t/)
     my $tfn = catfile($Bin, $tname);
 
     for (
-      qw|AccessorGroups.pm AccessorGroups/BeenThereDoneThat.pm AccessorGroupsRO.pm AccessorGroupsSubclass.pm AccessorGroupsWO.pm|,
+      qw|AccessorGroups.pm AccessorGroups/BeenThereDoneThat.pm AccessorGroupsRO.pm AccessorGroupsSubclass.pm AccessorGroupsParent.pm AccessorGroupsWO.pm|,
       File::Spec::Unix->catfile ($tfn),
     ) {
       delete $INC{$_};
diff --git a/t/accessors_xs_cachedwarn.t b/t/accessors_xs_cachedwarn.t
index 42f0ebf..f7c2c6b 100644
--- a/t/accessors_xs_cachedwarn.t
+++ b/t/accessors_xs_cachedwarn.t
@@ -19,11 +19,10 @@ BEGIN {
 }
 
 use AccessorGroupsSubclass;
-$Class::Accessor::Grouped::USE_XS = 1;
 
 my $obj = AccessorGroupsSubclass->new;
-my $obj2 = AccessorGroups->new;
 my $deferred_stub = AccessorGroupsSubclass->can('singlefield');
+my $obj2 = AccessorGroups->new;
 
 my @w;
 {
@@ -40,7 +39,7 @@ my @w;
 is (@w, 3, '3 warnings total');
 
 is (
-  scalar (grep { $_ =~ /^\QDeferred version of method AccessorGroups::singlefield invoked more than once/ } @w),
+  scalar (grep { $_ =~ /^\QDeferred version of method AccessorGroupsParent::singlefield invoked more than once/ } @w),
   3,
   '3 warnings produced as expected on cached invocation during testing',
 ) or do {
diff --git a/t/lib/AccessorGroups.pm b/t/lib/AccessorGroups.pm
index 10801c8..1d70e57 100644
--- a/t/lib/AccessorGroups.pm
+++ b/t/lib/AccessorGroups.pm
@@ -1,24 +1,9 @@
-{
-  package AccessorGroups::BeenThereDoneThat;
-
-  use strict;
-  use warnings;
-  use base 'Class::Accessor::Grouped';
-
-  __PACKAGE__->mk_group_accessors('simple', 'singlefield');
-  __PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/);
-}
-
-
 package AccessorGroups;
 use strict;
 use warnings;
-use base 'Class::Accessor::Grouped';
-__PACKAGE__->mk_group_accessors('simple', 'singlefield');
-__PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/);
-__PACKAGE__->mk_group_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]);
-__PACKAGE__->mk_group_accessors('simple', 'runtime_around');
-__PACKAGE__->mk_group_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (0..255) ) ]);
+use base 'AccessorGroupsParent';
+
+__PACKAGE__->mk_group_accessors('simple', [ fieldname_torture => join ('', reverse map { chr($_) } (0..255) ) ]);
 
 sub get_simple {
   my $v = shift->SUPER::get_simple (@_);
@@ -52,19 +37,9 @@ our $around_cref = sub {
 {
   no warnings qw/redefine/;
   eval <<'EOE';
-    sub AccessorGroups::runtime_around { goto $AccessorGroups::around_cref };
-    sub AccessorGroups::_runtime_around_accessor { goto $AccessorGroups::around_cref };
+    sub runtime_around { goto $around_cref };
+    sub _runtime_around_accessor { goto $around_cref };
 EOE
 }
 
-sub new {
-  return bless {}, shift;
-};
-
-foreach (qw/multiple listref/) {
-  no strict 'refs';
-  *{"get_$_"} = __PACKAGE__->can('get_simple');
-  *{"set_$_"} = __PACKAGE__->can('set_simple');
-};
-
 1;
diff --git a/t/lib/AccessorGroupsParent.pm b/t/lib/AccessorGroupsParent.pm
new file mode 100644
index 0000000..0921ec6
--- /dev/null
+++ b/t/lib/AccessorGroupsParent.pm
@@ -0,0 +1,37 @@
+BEGIN {
+  package AccessorGroups::BeenThereDoneThat;
+
+  use strict;
+  use warnings;
+  use base 'Class::Accessor::Grouped';
+
+  __PACKAGE__->mk_group_accessors('simple', 'singlefield');
+  __PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/);
+
+  my $dummy = bless {};
+  # tickle stuff at BEGIN time
+  $dummy->singlefield('foo');
+}
+
+
+package AccessorGroupsParent;
+use strict;
+use warnings;
+use base 'Class::Accessor::Grouped';
+__PACKAGE__->mk_group_accessors('simple', 'singlefield');
+__PACKAGE__->mk_group_accessors('multiple', qw/multiple1 multiple2/);
+__PACKAGE__->mk_group_accessors('listref', [qw/lr1name lr1;field/], [qw/lr2name lr2'field/]);
+__PACKAGE__->mk_group_accessors('simple', 'runtime_around');
+__PACKAGE__->mk_group_accessors('simple', [ fieldname_torture => join ('', map { chr($_) } (0..255) ) ]);
+
+sub new {
+  return bless {}, shift;
+};
+
+foreach (qw/multiple listref/) {
+  no strict 'refs';
+  *{"get_$_"} = __PACKAGE__->can('get_simple');
+  *{"set_$_"} = __PACKAGE__->can('set_simple');
+};
+
+1;