t/accessors.t

   1 use Test::More tests => 62;
   2 use strict;
   3 use warnings;
   4 use lib 't/lib';
   5 use Sub::Identify qw/sub_name sub_fullname/;
   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 AccessorGroups;
  20
  21 my $obj = AccessorGroups->new;
  22
  23 {
  24     my $class = ref $obj;
  25     my $name = 'multiple1';
  26     my $alias = "_${name}_accessor";
  27     my $accessor = $obj->can($name);
  28     my $alias_accessor = $obj->can($alias);
  29     isnt(sub_name($accessor), '__ANON__', 'accessor is named');
  30     isnt(sub_name($alias_accessor), '__ANON__', 'alias is named');
  31     is(sub_fullname($accessor), join('::',$class,$name), 'accessor FQ name');
  32     is(sub_fullname($alias_accessor), join('::',$class,$alias), 'alias FQ name');
  33
  34     my $warned = 0;
  35
  36     local $SIG{__WARN__} = sub {
  37         if  (shift =~ /DESTROY/i) {
  38             $warned++;
  39         };
  40     };
  41
  42     no warnings qw/once/;
  43     local *AccessorGroups::DESTROY = sub {};
  44
  45     $obj->mk_group_accessors('warnings', 'DESTROY');
  46     ok($warned);
  47 }
  48
  49 my $test_accessors = {
  50     singlefield => {
  51         is_xs => $use_xs,
  52         has_extra => 1,
  53     },
  54     multiple1 => {
  55     },
  56     multiple2 => {
  57     },
  58     lr1name => {
  59         custom_field => 'lr1;field',
  60     },
  61     lr2name => {
  62         custom_field => "lr2'field",
  63     },
  64 };
  65
  66
  67 for my $name (sort keys %$test_accessors) {
  68     my $alias = "_${name}_accessor";
  69     my $field = $test_accessors->{$name}{custom_field} || $name;
  70     my $extra = $test_accessors->{$name}{has_extra};
  71
  72     can_ok($obj, $name, $alias);
  73     ok(!$obj->can($field))
  74       if $field ne $name;
  75
  76     is($obj->$name, undef);
  77     is($obj->$alias, undef);
  78
  79     # get/set via name
  80     is($obj->$name('a'), 'a');
  81     is($obj->$name, 'a');
  82     is($obj->{$field}, $extra ? 'a Extra tackled on' : 'a');
  83
  84     # alias gets same as name
  85     is($obj->$alias, 'a');
  86
  87     # get/set via alias
  88     is($obj->$alias('b'), 'b');
  89     is($obj->$alias, 'b');
  90     is($obj->{$field}, $extra ? 'b Extra tackled on' : 'b');
  91
  92     # alias gets same as name
  93     is($obj->$name, 'b');
  94 };
  95
  96 # important
  97 1;