6 use B qw/svref_2object/;
8 # we test the pure-perl versions only, but allow overrides
9 # from the accessor_xs test-umbrella
10 # Also make sure a rogue envvar will not interfere with
14 $Class::Accessor::Grouped::USE_XS = 0
15 unless defined $Class::Accessor::Grouped::USE_XS;
17 $use_xs = $Class::Accessor::Grouped::USE_XS;
20 require AccessorGroupsSubclass;
22 my $test_accessors = {
28 # even though this accessor is declared as simple it will *not* be
29 # reinstalled due to the runtime 'around'
30 forced_class => 'AccessorGroups',
39 custom_field => 'lr1;field',
42 custom_field => "lr2'field",
44 fieldname_torture => {
46 custom_field => join ('', map { chr($_) } (0..255) ),
51 AccessorGroupsSubclass
55 my $obj = $class->new;
57 for my $name (sort keys %$test_accessors) {
58 my $alias = "_${name}_accessor";
59 my $field = $test_accessors->{$name}{custom_field} || $name;
60 my $extra = $test_accessors->{$name}{has_extra};
61 my $origin_class = 'AccessorGroupsParent';
63 if ( $class eq 'AccessorGroupsParent' ) {
64 next if $name eq 'runtime_around'; # implemented in the AG subclass
67 elsif ($name eq 'fieldname_torture') {
68 $field = reverse $field;
69 $origin_class = 'AccessorGroups';
72 can_ok($obj, $name, $alias);
73 ok(!$obj->can($field), "field for $name is not a method on $class")
79 for my $meth ($name, $alias) {
80 my $cv = svref_2object( $init_shims->{$meth} = $obj->can($meth) );
81 is($cv->GV->NAME, $meth, "initial ${class}::$meth accessor is named");
84 $test_accessors->{$name}{forced_class} || $origin_class,
85 "initial ${class}::$meth origin class correct",
89 is($obj->$name, undef, "${class}::$name begins undef");
90 is($obj->$alias, undef, "${class}::$alias begins undef");
93 is($obj->$name('a'), 'a', "${class}::$name setter RV correct");
94 is($obj->$name, 'a', "${class}::$name getter correct");
95 is($obj->{$field}, $extra ? 'a Extra tackled on' : 'a', "${class}::$name corresponding field correct");
97 # alias gets same as name
98 is($obj->$alias, 'a', "${class}::$alias getter correct after ${class}::$name setter");
101 is($obj->$alias('b'), 'b', "${class}::$alias setter RV correct");
102 is($obj->$alias, 'b', "${class}::$alias getter correct");
103 is($obj->{$field}, $extra ? 'b Extra tackled on' : 'b', "${class}::$alias corresponding field still correct");
105 # alias gets same as name
106 is($obj->$name, 'b', "${class}::$name getter correct after ${class}::$alias setter");
108 for my $meth ($name, $alias) {
109 my $resolved = $obj->can($meth);
111 my $cv = svref_2object($resolved);
112 is($cv->GV->NAME, $meth, "$meth accessor is named after operations");
114 $cv->GV->STASH->NAME,
115 # XS deferred subs install into each caller, not into the original parent
116 $test_accessors->{$name}{forced_class} || (
117 ($use_xs and $test_accessors->{$name}{is_simple})
121 "${class}::$meth origin class correct after operations",
124 # just simple for now
125 if ($use_xs and $test_accessors->{$name}{is_simple} and ! $test_accessors->{$name}{forced_class}) {
126 ok ($resolved != $init_shims->{$meth}, "$meth was replaced with a resolved version");
127 if ($class eq 'AccessorGroupsParent') {
128 ok ($cv->XSUB, "${class}::$meth is an XSUB");
131 ok (!$cv->XSUB, "${class}::$meth is *not* an XSUB (due to get_simple overrides)");
138 done_testing unless $::SUBTESTING;