t/accessors_wo.t

   1 use Test::More;
   2 use Test::Exception;
   3 use strict;
   4 use warnings;
   5 no warnings 'once';
   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 AccessorGroupsWO;
  21
  22 my $obj = AccessorGroupsWO->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 *AccessorGroupsWO::DESTROY = sub {};
  35
  36   $obj->mk_group_wo_accessors('warnings', 'DESTROY');
  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   fieldname_torture => {
  55     custom_field => join ('', map { chr($_) } (0..255) ),
  56     is_xs => $use_xs,
  57   },
  58 };
  59
  60 for my $name (sort keys %$test_accessors) {
  61
  62   my $alias = "_${name}_accessor";
  63   my $field = $test_accessors->{$name}{custom_field} || $name;
  64
  65   can_ok($obj, $name, $alias);
  66
  67   ok(!$obj->can($field))
  68     if $field ne $name;
  69
  70   # set via name
  71   is($obj->$name('a'), 'a');
  72   is($obj->{$field}, 'a');
  73
  74   # alias sets same as name
  75   is($obj->$alias('b'), 'b');
  76   is($obj->{$field}, 'b');
  77
  78   my $wo_regex = $test_accessors->{$name}{is_xs}
  79     ? qr/Usage\:.+$name.*\(self, newvalue\)/
  80     : qr/$name(:?_accessor)?\Q' cannot access its value (write-only attribute of class AccessorGroupsWO)/
  81   ;
  82
  83   # die on get via name/alias
  84   SKIP: {
  85     skip "Class::XSAccessor emits broken error messages on 5.10 and earlier", 1 if (
  86       $test_accessors->{$name}{is_xs}
  87         and
  88       $] < '5.011'
  89     );
  90
  91     throws_ok {
  92       $obj->$name;
  93     } $wo_regex;
  94
  95     throws_ok {
  96       $obj->$alias;
  97     } $wo_regex;
  98   }
  99 };
 100
 101 done_testing unless $::SUBTESTING;