t/accessors_ro.t

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