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
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) = @_;
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
&&
# 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
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 "
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;
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)
-use Test::More tests => 136;
+use Test::More;
use strict;
use warnings;
use lib 't/lib';
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 => {
},
};
-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;
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),
);
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{$_};
}
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;
{
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 {
-{
- 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 (@_);
{
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;
--- /dev/null
+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;
projects / p5sagit/Class-Accessor-Grouped.git / commitdiff