t/accessors.t

   1 use Test::More tests => 136;
   2 use strict;
   3 use warnings;
   4 use lib 't/lib';
   5 use B qw/svref_2object/;
   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 AccessorGroupsSubclass;
  20 my $obj = AccessorGroupsSubclass->new;
  21
  22 my $test_accessors = {
  23   singlefield => {
  24     is_xs => $use_xs,
  25     has_extra => 1,
  26   },
  27   runtime_around => {
  28     # even though this accessor is simple it will *not* be XSified
  29     # due to the runtime 'around'
  30     is_xs => 0,
  31     has_extra => 1,
  32   },
  33   multiple1 => {
  34   },
  35   multiple2 => {
  36   },
  37   lr1name => {
  38     custom_field => 'lr1;field',
  39   },
  40   lr2name => {
  41     custom_field => "lr2'field",
  42   },
  43   fieldname_torture => {
  44     custom_field => join ('', map { chr($_) } (0..255) ),
  45     is_xs => $use_xs,
  46   },
  47 };
  48
  49 for my $name (sort keys %$test_accessors) {
  50   my $alias = "_${name}_accessor";
  51   my $field = $test_accessors->{$name}{custom_field} || $name;
  52   my $extra = $test_accessors->{$name}{has_extra};
  53
  54   can_ok($obj, $name, $alias);
  55   ok(!$obj->can($field))
  56     if $field ne $name;
  57
  58   for my $meth ($name, $alias) {
  59     my $cv = svref_2object( $obj->can($meth) );
  60     is($cv->GV->NAME, $meth, "$meth accessor is named");
  61     is($cv->GV->STASH->NAME, 'AccessorGroups', "$meth class correct");
  62   }
  63
  64   is($obj->$name, undef);
  65   is($obj->$alias, undef);
  66
  67   # get/set via name
  68   is($obj->$name('a'), 'a');
  69   is($obj->$name, 'a');
  70   is($obj->{$field}, $extra ? 'a Extra tackled on' : 'a');
  71
  72   # alias gets same as name
  73   is($obj->$alias, 'a');
  74
  75   # get/set via alias
  76   is($obj->$alias('b'), 'b');
  77   is($obj->$alias, 'b');
  78   is($obj->{$field}, $extra ? 'b Extra tackled on' : 'b');
  79
  80   # alias gets same as name
  81   is($obj->$name, 'b');
  82
  83   for my $meth ($name, $alias) {
  84     my $cv = svref_2object( $obj->can($meth) );
  85     is($cv->GV->NAME, $meth, "$meth accessor is named after operations");
  86     is(
  87       $cv->GV->STASH->NAME,
  88       # XS lazyinstalls install into each caller, not into the original parent
  89       $test_accessors->{$name}{is_xs} ? 'AccessorGroupsSubclass' :'AccessorGroups',
  90       "$meth class correct after operations",
  91     );
  92   }
  93 };
  94
  95 # important
  96 1;