From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sat, 27 Nov 2010 16:50:48 +0000 (+0000)
Subject: Fix undefer debugger - calls to the same deferred stub going via different classes... 
X-Git-Tag: v0.10000~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FClass-Accessor-Grouped.git;a=commitdiff_plain;h=34051fe079d446e860cc2c6240488abfad3f85ac

Fix undefer debugger - calls to the same deferred stub going via different classes/objects are ok
---

diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index 69be59a..a73a687 100644
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -625,7 +625,7 @@ my $original_simple_setter = __PACKAGE__->can ('set_simple');
 # Note!!! Unusual signature
 $gen_accessor = sub {
   my ($type, $class, $group, $field, $methname) = @_;
-  if (my $c = ref $class) {
+  if (my $c = Scalar::Util::blessed( $class )) {
     $class = $c;
   }
 
@@ -649,17 +649,17 @@ $gen_accessor = sub {
 
       if (__CAG_TRACK_UNDEFER_FAIL) {
         my @cframe = caller(0);
-        if ($deferred_calls_seen{$cframe[3]}) {
+        if ($deferred_calls_seen{$current_class}{$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 "
+          . "invoked at $deferred_calls_seen{$current_class}{$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]";
+          $deferred_calls_seen{$current_class}{$cframe[3]} = "$cframe[1] line $cframe[2]";
         }
       }
 
diff --git a/t/accessors_xs_cachedwarn.t b/t/accessors_xs_cachedwarn.t
index acc1f48..14149c5 100644
--- a/t/accessors_xs_cachedwarn.t
+++ b/t/accessors_xs_cachedwarn.t
@@ -21,6 +21,7 @@ use AccessorGroupsSubclass;
 $Class::Accessor::Grouped::USE_XS = 1;
 
 my $obj = AccessorGroupsSubclass->new;
+my $obj2 = AccessorGroups->new;
 my $deferred_stub = AccessorGroupsSubclass->can('singlefield');
 
 my @w;
@@ -30,8 +31,13 @@ my @w;
   is ($obj->$deferred_stub, 1, 'Get');
   is ($obj->$deferred_stub(2), 2, 'ReSet');
   is ($obj->$deferred_stub, 2, 'ReGet');
+
+  is ($obj->singlefield, 2, 'Normal get');
+  is ($obj2->singlefield, undef, 'Normal get on unrelated object');
 }
 
+is (@w, 3, '3 warnings total');
+
 is (
   scalar (grep { $_ =~ /^\QDeferred version of method AccessorGroups::singlefield invoked more than once/ } @w),
   3,