t/accessors_wo.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 AccessorGroupsWO;
  22
  23 my $obj = AccessorGroupsWO->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 *AccessorGroupsWO::DESTROY = sub {};
  36
  37   $obj->mk_group_wo_accessors('warnings', 'DESTROY');
  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($_) } (0..255) ),
  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   # set via name
  72   is($obj->$name('a'), 'a');
  73   is($obj->{$field}, 'a');
  74
  75   # alias sets same as name
  76   is($obj->$alias('b'), 'b');
  77   is($obj->{$field}, 'b');
  78
  79   my $wo_regex = $test_accessors->{$name}{is_xs}
  80     ? qr/Usage\:.+$name.*\(self, newvalue\)/
  81     : qr/$name(:?_accessor)?\Q' cannot access its value (write-only attribute of class AccessorGroupsWO)/
  82   ;
  83
  84   # die on get via name/alias
  85   {
  86     local $TODO = "Class::XSAccessor emits broken error messages on 5.10 or -DDEBUGGING 5.8"
  87       if (
  88         $test_accessors->{$name}{is_xs}
  89           and
  90         $] < '5.011'
  91           and
  92         ( $] > '5.009' or $Config{config_args} =~ /DEBUGGING/ )
  93       );
  94
  95     throws_ok {
  96       $obj->$name;
  97     } $wo_regex;
  98
  99     throws_ok {
 100       $obj->$alias;
 101     } $wo_regex;
 102   }
 103 };
 104
 105 done_testing unless $::SUBTESTING;