From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sat, 27 Nov 2010 15:41:24 +0000 (+0000)
Subject: Add debugging of undefer code reentrancy when a test environment is detected
X-Git-Tag: v0.10000~5
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e6f2993f0eaf4c08632889be16acd8dada42fb6c;p=p5sagit%2FClass-Accessor-Grouped.git

Add debugging of undefer code reentrancy when a test environment is detected
---

diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index 3608fd5..82e28a2 100644
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -537,6 +537,15 @@ BEGIN {
     ? sub () { 1 }
     : sub () { 0 }
   ;
+
+
+  *__CAG_TRACK_UNDEFER_FAIL = (
+    $INC{'Test/Builder.pm'} || $INC{'Test/Builder2.pm'}
+      and
+    $0 =~ m|^ x?t / .+ \.t $|x
+  ) ? sub () { 1 }
+    : sub () { 0 }
+  ;
 }
 
 # Autodetect unless flag supplied
@@ -633,9 +642,27 @@ $gen_accessor = sub {
     die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_NO_CXSA )
       if __CAG_NO_CXSA;
 
+    my %deferred_calls_seen;
+
     return sub {
       my $current_class = Scalar::Util::blessed( $_[0] ) || $_[0];
 
+      if (__CAG_TRACK_UNDEFER_FAIL) {
+        my @cframe = caller(0);
+        if ($deferred_calls_seen{$cframe[3]}) {
+          Carp::carp (
+            "Deferred version of method $cframe[3] invoked more than once (originally "
+          . "invoked at $deferred_calls_seen{$cframe[3]}). This is a strong "
+          . 'indication your code has cached the original ->can derived method coderef, '
+          . 'and is using it instead of the proper method re-lookup, causing performance '
+          . 'regressions'
+          );
+        }
+        else {
+          $deferred_calls_seen{$cframe[3]} = "$cframe[1] line $cframe[2]";
+        }
+      }
+
       if (
         $current_class->can('get_simple') == $original_simple_getter
           &&
@@ -663,7 +690,8 @@ $gen_accessor = sub {
             . "set_simple\n";
         }
 
-        no strict qw/refs/;
+        no strict 'refs';
+        no warnings 'redefine';
 
         my $fq_name = "${current_class}::${methname}";
         *$fq_name = Sub::Name::subname($fq_name, do {
@@ -692,12 +720,12 @@ $gen_accessor = sub {
     local $@ if __CAG_UNSTABLE_DOLLARAT;
     eval "sub ${class}::${methname}{$src}";
 
-    undef;  # so that no attempt will be made to install anything
+    undef;  # so that no further attempt will be made to install anything
   }
 
   # a coderef generator with a variable pad (returns a fresh cref on every invocation)
   else {
-    ($accessor_maker_cache->{pp}{$group}{$field}{$type} ||= do {
+    ($accessor_maker_cache->{pp}{$type}{$group}{$field} ||= do {
       my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
         $maker_templates->{$type}{pp_code}->($group, $field);
 
diff --git a/t/accessors_xs.t b/t/accessors_xs.t
index 4694f84..c7f9de4 100644
--- a/t/accessors_xs.t
+++ b/t/accessors_xs.t
@@ -25,7 +25,7 @@ for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) {
     my $tfn = catfile($Bin, $tname);
 
     for (
-      qw/AccessorGroups.pm AccessorGroupsRO.pm AccessorGroupsSubclass.pm AccessorGroupsWO.pm/,
+      qw|AccessorGroups.pm AccessorGroups/BeenThereDoneThat.pm AccessorGroupsRO.pm AccessorGroupsSubclass.pm AccessorGroupsWO.pm|,
       File::Spec::Unix->catfile ($tfn),
     ) {
       delete $INC{$_};
diff --git a/t/accessors_xs_cachedwarn.t b/t/accessors_xs_cachedwarn.t
new file mode 100644
index 0000000..6b17dd4
--- /dev/null
+++ b/t/accessors_xs_cachedwarn.t
@@ -0,0 +1,41 @@
+use strict;
+use warnings;
+use FindBin qw($Bin);
+use File::Spec::Functions;
+use File::Spec::Unix (); # need this for %INC munging
+use Test::More;
+use lib 't/lib';
+
+BEGIN {
+    require Class::Accessor::Grouped;
+    my $xsa_ver = $Class::Accessor::Grouped::__minimum_xsa_version;
+    eval {
+        require Class::XSAccessor;
+        Class::XSAccessor->VERSION ($xsa_ver);
+    };
+    plan skip_all => "Class::XSAccessor >= $xsa_ver not available"
+      if $@;
+}
+
+use AccessorGroupsSubclass;
+$Class::Accessor::Grouped::USE_XS = 1;
+
+my $obj = AccessorGroupsSubclass->new;
+my $deferred_stub = AccessorGroupsSubclass->can('singlefield');
+
+my @w;
+{
+  local $SIG{__WARN__} = sub { push @w, @_ };
+  is ($obj->$deferred_stub(1), 1, 'Set');
+  is ($obj->$deferred_stub, 1, 'Get');
+  is ($obj->$deferred_stub(2), 2, 'ReSet');
+  is ($obj->$deferred_stub, 2, 'ReGet');
+}
+
+is (
+  scalar (grep { $_ =~ /^\QDeferred version of method AccessorGroups::singlefield invoked more than once/ } @w),
+  3
+  '3 warnings produced as expected on cached invocation during testing'
+);
+
+done_testing;