1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
use Test::More;
use strict;
use warnings;
no warnings 'once';
use lib 't/lib';
use B qw/svref_2object/;
# we test the pure-perl versions only, but allow overrides
# from the accessor_xs test-umbrella
# Also make sure a rogue envvar will not interfere with
# things
my $use_xs;
BEGIN {
$Class::Accessor::Grouped::USE_XS = 0
unless defined $Class::Accessor::Grouped::USE_XS;
$ENV{CAG_USE_XS} = 1;
$use_xs = $Class::Accessor::Grouped::USE_XS;
};
require AccessorGroupsSubclass;
my $test_accessors = {
singlefield => {
is_simple => 1,
has_extra => 1,
},
runtime_around => {
# even though this accessor is declared as simple it will *not* be
# reinstalled due to the runtime 'around'
forced_class => 'AccessorGroups',
is_simple => 1,
has_extra => 1,
},
multiple1 => {
},
multiple2 => {
},
lr1name => {
custom_field => 'lr1;field',
},
lr2name => {
custom_field => "lr2'field",
},
fieldname_torture => {
is_simple => 1,
custom_field => join ('', map { chr($_) } (0..255) ),
},
};
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), "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( $init_shims->{$meth} = $obj->can($meth) );
is($cv->GV->NAME, $meth, "initial ${class}::$meth accessor is named");
is(
$cv->GV->STASH->NAME,
$test_accessors->{$name}{forced_class} || $origin_class,
"initial ${class}::$meth origin class correct",
);
}
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', "${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', "${class}::$alias getter correct after ${class}::$name setter");
# get/set via alias
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', "${class}::$name getter correct after ${class}::$alias setter");
for my $meth ($name, $alias) {
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
$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)");
}
}
}
}
}
done_testing unless $::SUBTESTING;
|
