use Test::More tests => 48;
use Test::Exception;
use strict;
use warnings;
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",
},
};
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/cannot alter the value of '\Q$field\E'/
;
# 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');
};
#important
1;