t/accessors_wo.t

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