t/accessors_ro.t

   1 use Test::More tests => 48;
   2 use Test::Exception;
   3 use strict;
   4 use warnings;
   5 use lib 't/lib';
   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
  11 my $use_xs;
  12 BEGIN {
  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
  19 use AccessorGroupsRO;
  20
  21 my $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);
  35
  36     # restore non-accessorized DESTROY
  37     no warnings;
  38     *AccessorGroupsRO::DESTROY = sub {};
  39 };
  40
  41 my $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
  57 for my $name (sort keys %$test_accessors) {
  58
  59     my $alias = "_${name}_accessor";
  60     my $field = $test_accessors->{$name}{custom_field} || $name;
  61
  62     can_ok($class, $name, $alias);
  63
  64     ok(!$class->can($field))
  65       if $field ne $name;
  66
  67     is($class->$name, undef);
  68     is($class->$alias, undef);
  69
  70     # get via name
  71     $class->{$field} = 'a';
  72     is($class->$name, 'a');
  73
  74     # alias gets same as name
  75     is($class->$alias, 'a');
  76
  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
  82     # die on set via name/alias
  83     throws_ok {
  84         $class->$name('b');
  85     } $ro_regex;
  86
  87     throws_ok {
  88         $class->$alias('b');
  89     } $ro_regex;
  90
  91     # value should be unchanged
  92     is($class->$name, 'a');
  93     is($class->$alias, 'a');
  94 };
  95
  96 #important
  97 1;