t/accessors.t

   1 use Test::More;
   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 require AccessorGroupsSubclass;
  20
  21 my $test_accessors = {
  22   singlefield => {
  23     is_simple => 1,
  24     has_extra => 1,
  25   },
  26   runtime_around => {
  27     # even though this accessor is declared as simple it will *not* be
  28     # reinstalled due to the runtime 'around'
  29     forced_class => 'AccessorGroups',
  30     is_simple => 1,
  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     is_simple => 1,
  45     custom_field => join ('', map { chr($_) } (0..255) ),
  46   },
  47 };
  48
  49 for my $class (qw(
  50   AccessorGroupsSubclass
  51   AccessorGroups
  52   AccessorGroupsParent
  53 )) {
  54   my $obj = $class->new;
  55
  56   for my $name (sort keys %$test_accessors) {
  57     my $alias = "_${name}_accessor";
  58     my $field = $test_accessors->{$name}{custom_field} || $name;
  59     my $extra = $test_accessors->{$name}{has_extra};
  60     my $origin_class = 'AccessorGroupsParent';
  61
  62     if ( $class eq 'AccessorGroupsParent' ) {
  63       next if $name eq 'runtime_around';  # implemented in the AG subclass
  64       $extra = 0;
  65     }
  66     elsif ($name eq 'fieldname_torture') {
  67       $field = reverse $field;
  68       $origin_class = 'AccessorGroups';
  69     }
  70
  71     can_ok($obj, $name, $alias);
  72     ok(!$obj->can($field), "field for $name is not a method on $class")
  73       if $field ne $name;
  74
  75     my $init_shims;
  76
  77     # initial method name
  78     for my $meth ($name, $alias) {
  79       my $cv = svref_2object( $init_shims->{$meth} = $obj->can($meth) );
  80       is($cv->GV->NAME, $meth, "initial ${class}::$meth accessor is named");
  81       is(
  82         $cv->GV->STASH->NAME,
  83         $test_accessors->{$name}{forced_class} || $origin_class,
  84         "initial ${class}::$meth origin class correct",
  85       );
  86     }
  87
  88     is($obj->$name, undef, "${class}::$name begins undef");
  89     is($obj->$alias, undef, "${class}::$alias begins undef");
  90
  91     # get/set via name
  92     is($obj->$name('a'), 'a', "${class}::$name setter RV correct");
  93     is($obj->$name, 'a', "${class}::$name getter correct");
  94     is($obj->{$field}, $extra ? 'a Extra tackled on' : 'a', "${class}::$name corresponding field correct");
  95
  96     # alias gets same as name
  97     is($obj->$alias, 'a', "${class}::$alias getter correct after ${class}::$name setter");
  98
  99     # get/set via alias
 100     is($obj->$alias('b'), 'b', "${class}::$alias setter RV correct");
 101     is($obj->$alias, 'b', "${class}::$alias getter correct");
 102     is($obj->{$field}, $extra ? 'b Extra tackled on' : 'b', "${class}::$alias corresponding field still correct");
 103
 104     # alias gets same as name
 105     is($obj->$name, 'b', "${class}::$name getter correct after ${class}::$alias setter");
 106
 107     for my $meth ($name, $alias) {
 108       my $resolved = $obj->can($meth);
 109
 110       my $cv = svref_2object($resolved);
 111       is($cv->GV->NAME, $meth, "$meth accessor is named after operations");
 112       is(
 113         $cv->GV->STASH->NAME,
 114         # XS deferred subs install into each caller, not into the original parent
 115         $test_accessors->{$name}{forced_class} || (
 116           ($use_xs and $test_accessors->{$name}{is_simple})
 117             ? (ref $obj)
 118             : $origin_class
 119         ),
 120         "${class}::$meth origin class correct after operations",
 121       );
 122
 123       # just simple for now
 124       if ($use_xs and $test_accessors->{$name}{is_simple} and ! $test_accessors->{$name}{forced_class}) {
 125         ok ($resolved != $init_shims->{$meth}, "$meth was replaced with a resolved version");
 126         if ($class eq 'AccessorGroupsParent') {
 127           ok ($cv->XSUB, "${class}::$meth is an XSUB");
 128         }
 129         else {
 130           ok (!$cv->XSUB, "${class}::$meth is *not* an XSUB (due to get_simple overrides)");
 131         }
 132       }
 133     }
 134   }
 135 }
 136
 137 done_testing;