[Bast-commits] r9804 - in Class-Accessor-Grouped/trunk: lib/Class/Accessor t

[ribasushi at dev.catalyst.perl.org]

Author: ribasushi
Date: 2010-11-27 16:50:48 +0000 (Sat, 27 Nov 2010)
New Revision: 9804

Modified:
   Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm
   Class-Accessor-Grouped/trunk/t/accessors_xs_cachedwarn.t
Log:
Fix undefer debugger - calls to the same deferred stub going via different classes/objects are ok

Modified: Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm
===================================================================
--- Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm	2010-11-27 15:46:12 UTC (rev 9803)
+++ Class-Accessor-Grouped/trunk/lib/Class/Accessor/Grouped.pm	2010-11-27 16:50:48 UTC (rev 9804)
@@ -625,7 +625,7 @@
 # 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 @@
 
       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]";
         }
       }
 

Modified: Class-Accessor-Grouped/trunk/t/accessors_xs_cachedwarn.t
===================================================================
--- Class-Accessor-Grouped/trunk/t/accessors_xs_cachedwarn.t	2010-11-27 15:46:12 UTC (rev 9803)
+++ Class-Accessor-Grouped/trunk/t/accessors_xs_cachedwarn.t	2010-11-27 16:50:48 UTC (rev 9804)
@@ -21,6 +21,7 @@
 $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 @@
   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,