[Bast-commits] r9804 - in Class-Accessor-Grouped/trunk:
lib/Class/Accessor t
ribasushi at dev.catalyst.perl.org
ribasushi at dev.catalyst.perl.org
Sat Nov 27 16:50:48 GMT 2010
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,
More information about the Bast-commits
mailing list