Fix braindead ro/wo accessor breakage when CXSA is available
[p5sagit/Class-Accessor-Grouped.git] / t / accessors_ro.t
CommitLineData
c26cc2b9 1use Test::More tests => 48;
8019c4d8 2use Test::Exception;
6a48652b 3use strict;
4use warnings;
5use lib 't/lib';
8019c4d8 6
7# we test the pure-perl versions only, but allow overrides
8# from the accessor_xs test-umbrella
9# Also make sure a rogue envvar will not interfere with
10# things
11my $use_xs;
12BEGIN {
13 $Class::Accessor::Grouped::USE_XS = 0
14 unless defined $Class::Accessor::Grouped::USE_XS;
15 $ENV{CAG_USE_XS} = 1;
16 $use_xs = $Class::Accessor::Grouped::USE_XS;
17};
18
6a48652b 19use AccessorGroupsRO;
20
21my $class = AccessorGroupsRO->new;
22
23{
24 my $warned = 0;
25
26 local $SIG{__WARN__} = sub {
27 if (shift =~ /DESTROY/i) {
28 $warned++;
29 };
30 };
31
32 $class->mk_group_ro_accessors('warnings', 'DESTROY');
33
34 ok($warned);
c26cc2b9 35
36 # restore non-accessorized DESTROY
37 no warnings;
38 *AccessorGroupsRO::DESTROY = sub {};
6a48652b 39};
40
8019c4d8 41my $test_accessors = {
42 singlefield => {
43 is_xs => $use_xs,
44 },
45 multiple1 => {
46 },
47 multiple2 => {
48 },
49 lr1name => {
50 custom_field => 'lr1;field',
51 },
52 lr2name => {
53 custom_field => "lr2'field",
54 },
55};
56
57for my $name (sort keys %$test_accessors) {
58
6a48652b 59 my $alias = "_${name}_accessor";
8019c4d8 60 my $field = $test_accessors->{$name}{custom_field} || $name;
6a48652b 61
62 can_ok($class, $name, $alias);
63
8019c4d8 64 ok(!$class->can($field))
65 if $field ne $name;
66
6a48652b 67 is($class->$name, undef);
68 is($class->$alias, undef);
69
70 # get via name
8019c4d8 71 $class->{$field} = 'a';
6a48652b 72 is($class->$name, 'a');
73
74 # alias gets same as name
75 is($class->$alias, 'a');
76
8019c4d8 77 my $ro_regex = $test_accessors->{$name}{is_xs}
78 ? qr/Usage\:.+$name.*\(self\)/
79 : qr/cannot alter the value of '\Q$field\E'/
80 ;
81
6a48652b 82 # die on set via name/alias
8019c4d8 83 throws_ok {
6a48652b 84 $class->$name('b');
8019c4d8 85 } $ro_regex;
6a48652b 86
8019c4d8 87 throws_ok {
6a48652b 88 $class->$alias('b');
8019c4d8 89 } $ro_regex;
6a48652b 90
91 # value should be unchanged
92 is($class->$name, 'a');
93 is($class->$alias, 'a');
94};
95
8019c4d8 96#important
971;