lib/base/t/fields-base.t

   1 #!/usr/bin/perl -w
   2
   3 BEGIN {
   4    if( $ENV{PERL_CORE} ) {
   5         chdir 't' if -d 't';
   6         @INC = qw(../lib);
   7     }
   8 }
   9
  10 my ($Has_PH, $Field);
  11 BEGIN {
  12     $Has_PH = $] < 5.009;
  13     $Field = $Has_PH ? "pseudo-hash field" : "class field";
  14 }
  15
  16 my $W;
  17
  18 BEGIN {
  19     $W = 0;
  20     $SIG{__WARN__} = sub {
  21         if ($_[0] =~ /^Hides field '.*?' in base class/) {
  22             $W++;
  23         }
  24         else {
  25             warn $_[0];
  26         }
  27     };
  28 }
  29
  30 use strict;
  31 use Test::More tests => 29;
  32
  33 BEGIN { use_ok('base'); }
  34
  35 package B1;
  36 use fields qw(b1 b2 b3);
  37
  38 package B2;
  39 use fields '_b1';
  40 use fields qw(b1 _b2 b2);
  41
  42 sub new { fields::new(shift) }
  43
  44 package B3;
  45 use fields qw(b4 _b5 b6 _b7);
  46
  47 package D1;
  48 use base 'B1';
  49 use fields qw(d1 d2 d3);
  50
  51 package D2;
  52 use base 'B1';
  53 use fields qw(_d1 _d2);
  54 use fields qw(d1 d2);
  55
  56
  57 package D3;
  58 use base 'B2';
  59 use fields qw(b1 d1 _b1 _d1);  # hide b1
  60
  61 package D4;
  62 use base 'D3';
  63 use fields qw(_d3 d3);
  64
  65 package M;
  66 sub m {}
  67
  68 package D5;
  69 use base qw(M B2);
  70
  71 # Test that multiple inheritance fails.
  72 package D6;
  73 eval { 'base'->import(qw(B2 M B3)); };
  74 ::like($@, qr/can't multiply inherit fields/i,
  75     'No multiple field inheritance');
  76
  77 package Foo::Bar;
  78 use base 'B1';
  79
  80 package Foo::Bar::Baz;
  81 use base 'Foo::Bar';
  82 use fields qw(foo bar baz);
  83
  84 # Test repeatability for when modules get reloaded.
  85 package B1;
  86 use fields qw(b1 b2 b3);
  87
  88 package D3;
  89 use base 'B2';
  90 use fields qw(b1 d1 _b1 _d1);  # hide b1
  91
  92
  93 # Test that a package with only private fields gets inherited properly
  94 package B7;
  95 use fields qw(_b1);
  96
  97 package D7;
  98 use base qw(B7);
  99 use fields qw(b1);
 100
 101
 102 # Test that an intermediate package with no fields doesn't cause a problem.
 103 package B8;
 104 use fields qw(_b1);
 105
 106 package D8;
 107 use base qw(B8);
 108
 109 package D8A;
 110 use base qw(D8);
 111 use fields qw(b1);
 112
 113
 114 package main;
 115
 116 my %EXPECT = (
 117               B1 => [qw(b1 b2 b3)],
 118               D1 => [qw(b1 b2 b3 d1 d2 d3)],
 119               D2 => [qw(b1 b2 b3 _d1 _d2 d1 d2)],
 120
 121               M  => [qw()],
 122               B2 => [qw(_b1 b1 _b2 b2)],
 123               D3 => [(undef,undef,undef,
 124                                 qw(b2 b1 d1 _b1 _d1))],     # b1 is hidden
 125               D4 => [(undef,undef,undef,
 126                                 qw(b2 b1 d1),undef,undef,qw(_d3 d3))],
 127
 128               D5 => [undef, 'b1', undef, 'b2'],
 129
 130               B3 => [qw(b4 _b5 b6 _b7)],
 131
 132               B7 => [qw(_b1)],
 133               D7 => [undef, 'b1'],
 134
 135               B8  => [qw(_b1)],
 136               D8  => [undef],
 137               D8A => [undef, 'b1'],
 138
 139               'Foo::Bar'        => [qw(b1 b2 b3)],
 140               'Foo::Bar::Baz'   => [qw(b1 b2 b3 foo bar baz)],
 141              );
 142
 143 while(my($class, $efields) = each %EXPECT) {
 144     no strict 'refs';
 145     my %fields = %{$class.'::FIELDS'};
 146     my %expected_fields;
 147     foreach my $idx (1..@$efields) {
 148         my $key = $efields->[$idx-1];
 149         next unless $key;
 150         $expected_fields{$key} = $idx;
 151     }
 152
 153     ::is_deeply(\%fields, \%expected_fields, "%FIELDS check:  $class");
 154 }
 155
 156 # Did we get the appropriate amount of warnings?
 157 is( $W, 1, 'right warnings' );
 158
 159
 160 # A simple object creation and attribute access test
 161 my B2 $obj1 = D3->new;
 162 $obj1->{b1} = "B2";
 163 my D3 $obj2 = $obj1;
 164 $obj2->{b1} = "D3";
 165
 166 # We should get compile time failures field name typos
 167 eval q(return; my D3 $obj3 = $obj2; $obj3->{notthere} = "");
 168 like $@,
 169     qr/^No such $Field "notthere" in variable \$obj3 of type D3/,
 170     "Compile failure of undeclared fields (helem)";
 171
 172 SKIP: {
 173     # Slices
 174     # We should get compile time failures field name typos
 175     skip "Doesn't work before 5.9", 2 if $] < 5.009;
 176     eval q(return; my D3 $obj3 = $obj2; my $k; @$obj3{$k,'notthere'} = ());
 177     like $@,
 178         qr/^No such $Field "notthere" in variable \$obj3 of type D3/,
 179         "Compile failure of undeclared fields (hslice)";
 180     eval q(return; my D3 $obj3 = $obj2; my $k; @{$obj3}{$k,'notthere'} = ());
 181     like
 182         $@, qr/^No such $Field "notthere" in variable \$obj3 of type D3/,
 183         "Compile failure of undeclared fields (hslice (block form))";
 184 }
 185
 186 @$obj1{"_b1", "b1"} = (17, 29);
 187 is( $obj1->{_b1}, 17 );
 188 is( $obj1->{b1},  29 );
 189
 190 @$obj1{'_b1', 'b1'} = (44,28);
 191 is( $obj1->{_b1}, 44 );
 192 is( $obj1->{b1},  28 );
 193
 194
 195
 196 # Break multiple inheritance with a field name clash.
 197 package E1;
 198 use fields qw(yo this _lah meep 42);
 199
 200 package E2;
 201 use fields qw(_yo ahhh this);
 202
 203 eval {
 204     package Broken;
 205
 206     # The error must occur at run time for the eval to catch it.
 207     require base;
 208     'base'->import(qw(E1 E2));
 209 };
 210 ::like( $@, qr/Can't multiply inherit fields/i, 'Again, no multi inherit' );
 211
 212
 213 # Test that a package with no fields can inherit from a package with
 214 # fields, and that pseudohash messages don't show up
 215
 216 package B9;
 217 use fields qw(b1);
 218
 219 sub _mk_obj { fields::new($_[0])->{'b1'} };
 220
 221 package D9;
 222 use base qw(B9);
 223
 224 package main;
 225
 226 {
 227     my $w = 0;
 228     local $SIG{__WARN__} = sub { $w++ };
 229
 230     B9->_mk_obj();
 231     # used tp emit a warning that pseudohashes are deprecated, because
 232     # %FIELDS wasn't blessed.
 233     D9->_mk_obj();
 234
 235     is ($w, 0, "pseudohash warnings in derived class with no fields of it's own");
 236 }
 237
 238 # [perl #31078] an intermediate class with no additional fields caused
 239 # hidden fields in base class to get stomped on
 240
 241 {
 242     package X;
 243     use fields qw(X1 _X2);
 244     sub new {
 245         my X $self = shift;
 246         $self = fields::new($self) unless ref $self;
 247         $self->{X1} = "x1";
 248         $self->{_X2} = "_x2";
 249         return $self;
 250     }
 251     sub get_X2 { my X $self = shift; $self->{_X2} }
 252
 253     package Y;
 254     use base qw(X);
 255
 256     sub new {
 257         my Y $self = shift;
 258         $self = fields::new($self) unless ref $self;
 259         $self->SUPER::new();
 260         return $self;
 261     }
 262
 263
 264     package Z;
 265     use base qw(Y);
 266     use fields qw(Z1);
 267
 268     sub new {
 269         my Z $self = shift;
 270         $self = fields::new($self) unless ref $self;
 271         $self->SUPER::new();
 272         $self->{Z1} = 'z1';
 273         return $self;
 274     }
 275
 276     package main;
 277
 278         my Z $c = Z->new();
 279         is($c->get_X2, '_x2', "empty intermediate class");
 280 }