t/accessors.t

   1 use Test::More tests => 138;
   2 use Test::Exception;
   3 use strict;
   4 use warnings;
   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 use AccessorGroupsSubclass;
  21
  22 SKIP: {
  23   skip( 'Perl 5.6 does not like localizing globs', 1 )
  24     if $] < '5.008';
  25
  26   my $obj = AccessorGroupsSubclass->new;
  27   my $class = ref $obj;
  28   my $name = 'multiple1';
  29   my $alias = "_${name}_accessor";
  30
  31   my $warned = 0;
  32   local $SIG{__WARN__} = sub {
  33     $_[0] =~ /unwise/ ? $warned++ : warn(@_)
  34   };
  35
  36   for (qw/DESTROY AUTOLOAD CLONE/) {
  37     no warnings qw/once/;
  38     no strict 'refs';
  39
  40     local *{"AccessorGroupsSubclass::$_"} = sub {};
  41
  42     $class->mk_group_accessors(warnings => $_);
  43   }
  44
  45   is($warned, 3, 'Correct amount of warnings');
  46 };
  47
  48 throws_ok { AccessorGroupsSubclass->mk_group_accessors(simple => '2wrvwrv;') }
  49   qr/Illegal accessor name/;
  50
  51 my $obj = AccessorGroupsSubclass->new;
  52
  53 my $test_accessors = {
  54   singlefield => {
  55     is_xs => $use_xs,
  56     has_extra => 1,
  57   },
  58   runtime_around => {
  59     # even though this accessor is simple it will *not* be XSified
  60     # due to the runtime 'around'
  61     is_xs => 0,
  62     has_extra => 1,
  63   },
  64   multiple1 => {
  65   },
  66   multiple2 => {
  67   },
  68   lr1name => {
  69     custom_field => 'lr1;field',
  70   },
  71   lr2name => {
  72     custom_field => "lr2'field",
  73   },
  74   fieldname_torture => {
  75     custom_field => join ('', map { chr($_) } (0..255) ),
  76     is_xs => $use_xs,
  77   },
  78 };
  79
  80 for my $name (sort keys %$test_accessors) {
  81   my $alias = "_${name}_accessor";
  82   my $field = $test_accessors->{$name}{custom_field} || $name;
  83   my $extra = $test_accessors->{$name}{has_extra};
  84
  85   can_ok($obj, $name, $alias);
  86   ok(!$obj->can($field))
  87     if $field ne $name;
  88
  89   for my $meth ($name, $alias) {
  90     my $cv = svref_2object( $obj->can($meth) );
  91     is($cv->GV->NAME, $meth, "$meth accessor is named");
  92     is($cv->GV->STASH->NAME, 'AccessorGroups', "$meth class correct");
  93   }
  94
  95   is($obj->$name, undef);
  96   is($obj->$alias, undef);
  97
  98   # get/set via name
  99   is($obj->$name('a'), 'a');
 100   is($obj->$name, 'a');
 101   is($obj->{$field}, $extra ? 'a Extra tackled on' : 'a');
 102
 103   # alias gets same as name
 104   is($obj->$alias, 'a');
 105
 106   # get/set via alias
 107   is($obj->$alias('b'), 'b');
 108   is($obj->$alias, 'b');
 109   is($obj->{$field}, $extra ? 'b Extra tackled on' : 'b');
 110
 111   # alias gets same as name
 112   is($obj->$name, 'b');
 113
 114   for my $meth ($name, $alias) {
 115     my $cv = svref_2object( $obj->can($meth) );
 116     is($cv->GV->NAME, $meth, "$meth accessor is named after operations");
 117     is(
 118       $cv->GV->STASH->NAME,
 119       # XS lazyinstalls install into each caller, not into the original parent
 120       $test_accessors->{$name}{is_xs} ? 'AccessorGroupsSubclass' :'AccessorGroups',
 121       "$meth class correct after operations",
 122     );
 123   }
 124 };
 125
 126 # important
 127 1;