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
|
use Test::More;
use Test::Exception;
use strict;
use warnings;
no warnings 'once';
use lib 't/lib';
# 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;
};
use AccessorGroupsRO;
my $obj = AccessorGroupsRO->new;
{
my $warned = 0;
local $SIG{__WARN__} = sub {
if (shift =~ /DESTROY/i) {
$warned++;
};
};
no warnings qw/once/;
local *AccessorGroupsRO::DESTROY = sub {};
$obj->mk_group_ro_accessors('warnings', 'DESTROY');
ok($warned);
};
my $test_accessors = {
singlefield => {
is_xs => $use_xs,
},
multiple1 => {
},
multiple2 => {
},
lr1name => {
custom_field => 'lr1;field',
},
lr2name => {
custom_field => "lr2'field",
},
fieldname_torture => {
custom_field => join ('', map { chr($_) } (0..255) ),
is_xs => $use_xs,
},
};
for my $name (sort keys %$test_accessors) {
my $alias = "_${name}_accessor";
my $field = $test_accessors->{$name}{custom_field} || $name;
can_ok($obj, $name, $alias);
ok(!$obj->can($field))
if $field ne $name;
is($obj->$name, undef);
is($obj->$alias, undef);
# get via name
$obj->{$field} = 'a';
is($obj->$name, 'a');
# alias gets same as name
is($obj->$alias, 'a');
my $ro_regex = $test_accessors->{$name}{is_xs}
? qr/Usage\:.+$name.*\(self\)/
: qr/$name(:?_accessor)?\Q' cannot alter its value (read-only attribute of class AccessorGroupsRO)/
;
SKIP: {
skip "Class::XSAccessor emits broken error messages on 5.10 and earlier", 1 if (
$test_accessors->{$name}{is_xs}
and
$] < '5.011'
);
# die on set via name/alias
throws_ok {
$obj->$name('b');
} $ro_regex;
throws_ok {
$obj->$alias('b');
} $ro_regex;
}
# value should be unchanged
is($obj->$name, 'a');
is($obj->$alias, 'a');
};
done_testing unless $::SUBTESTING;
|
