t/accessors_ro.t

   1 use Test::More;
   2 use Test::Exception;
   3 use strict;
   4 use warnings;
   5 no warnings 'once';
   6 use Config;
   7 use lib 't/lib';
   8
   9 # we test the pure-perl versions only, but allow overrides
  10 # from the accessor_xs test-umbrella
  11 # Also make sure a rogue envvar will not interfere with
  12 # things
  13 my $use_xs;
  14 BEGIN {
  15   $Class::Accessor::Grouped::USE_XS = 0
  16     unless defined $Class::Accessor::Grouped::USE_XS;
  17   $ENV{CAG_USE_XS} = 1;
  18   $use_xs = $Class::Accessor::Grouped::USE_XS;
  19 };
  20
  21 use AccessorGroupsRO;
  22
  23 my $obj = AccessorGroupsRO->new;
  24
  25 {
  26   my $warned = 0;
  27
  28   local $SIG{__WARN__} = sub {
  29     if  (shift =~ /DESTROY/i) {
  30       $warned++;
  31     };
  32   };
  33
  34   no warnings qw/once/;
  35   local *AccessorGroupsRO::DESTROY = sub {};
  36
  37   $obj->mk_group_ro_accessors('warnings', 'DESTROY');
  38
  39   ok($warned);
  40 };
  41
  42 my $test_accessors = {
  43   singlefield => {
  44     is_xs => $use_xs,
  45   },
  46   multiple1 => {
  47   },
  48   multiple2 => {
  49   },
  50   lr1name => {
  51     custom_field => 'lr1;field',
  52   },
  53   lr2name => {
  54     custom_field => "lr2'field",
  55   },
  56   fieldname_torture => {
  57     custom_field => join ('', map { chr($_) } (0..255) ),
  58     is_xs => $use_xs,
  59   },
  60 };
  61
  62 for my $name (sort keys %$test_accessors) {
  63
  64   my $alias = "_${name}_accessor";
  65   my $field = $test_accessors->{$name}{custom_field} || $name;
  66
  67   can_ok($obj, $name, $alias);
  68
  69   ok(!$obj->can($field))
  70     if $field ne $name;
  71
  72   is($obj->$name, undef);
  73   is($obj->$alias, undef);
  74
  75   # get via name
  76   $obj->{$field} = 'a';
  77   is($obj->$name, 'a');
  78
  79   # alias gets same as name
  80   is($obj->$alias, 'a');
  81
  82   my $ro_regex = $test_accessors->{$name}{is_xs}
  83     ? qr/Usage\:.+$name.*\(self\)/
  84     : qr/$name(:?_accessor)?\Q' cannot alter its value (read-only attribute of class AccessorGroupsRO)/
  85   ;
  86
  87   {
  88     local $TODO = "Class::XSAccessor emits broken error messages on 5.10 or -DDEBUGGING 5.8"
  89       if (
  90         $test_accessors->{$name}{is_xs}
  91           and
  92         $] < '5.011'
  93           and
  94         ( $] > '5.009' or $Config{config_args} =~ /DEBUGGING/ )
  95       );
  96
  97     # die on set via name/alias
  98     throws_ok {
  99       $obj->$name('b');
 100     } $ro_regex;
 101
 102     throws_ok {
 103       $obj->$alias('b');
 104     } $ro_regex;
 105   }
 106
 107   # value should be unchanged
 108   is($obj->$name, 'a');
 109   is($obj->$alias, 'a');
 110 };
 111
 112 done_testing unless $::SUBTESTING;