t/accessors.t

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