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 $obj = 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   no warnings qw/once/;
  33   local *AccessorGroupsRO::DESTROY = sub {};
  34
  35   $obj->mk_group_ro_accessors('warnings', 'DESTROY');
  36
  37   ok($warned);
  38 };
  39
  40 my $test_accessors = {
  41   singlefield => {
  42     is_xs => $use_xs,
  43   },
  44   multiple1 => {
  45   },
  46   multiple2 => {
  47   },
  48   lr1name => {
  49     custom_field => 'lr1;field',
  50   },
  51   lr2name => {
  52     custom_field => "lr2'field",
  53   },
  54 };
  55
  56 for my $name (sort keys %$test_accessors) {
  57
  58   my $alias = "_${name}_accessor";
  59   my $field = $test_accessors->{$name}{custom_field} || $name;
  60
  61   can_ok($obj, $name, $alias);
  62
  63   ok(!$obj->can($field))
  64     if $field ne $name;
  65
  66   is($obj->$name, undef);
  67   is($obj->$alias, undef);
  68
  69   # get via name
  70   $obj->{$field} = 'a';
  71   is($obj->$name, 'a');
  72
  73   # alias gets same as name
  74   is($obj->$alias, 'a');
  75
  76   my $ro_regex = $test_accessors->{$name}{is_xs}
  77     ? qr/Usage\:.+$name.*\(self\)/
  78     : qr/cannot alter the value of '\Q$field\E'/
  79   ;
  80
  81   # die on set via name/alias
  82   throws_ok {
  83     $obj->$name('b');
  84   } $ro_regex;
  85
  86   throws_ok {
  87     $obj->$alias('b');
  88   } $ro_regex;
  89
  90   # value should be unchanged
  91   is($obj->$name, 'a');
  92   is($obj->$alias, 'a');
  93 };
  94
  95 #important
  96 1;