lib/fields.t

   1 #!./perl -w
   2
   3 my $w;
   4
   5 BEGIN {
   6    chdir 't' if -d 't';
   7    @INC = '../lib';
   8    $SIG{__WARN__} = sub {
   9        if ($_[0] =~ /^Hides field 'b1' in base class/) {
  10            $w++;
  11            return;
  12        }
  13        print $_[0];
  14    };
  15 }
  16
  17 use strict;
  18 use warnings;
  19 use vars qw($DEBUG);
  20
  21 use Test::More;
  22
  23
  24 package B1;
  25 use fields qw(b1 b2 b3);
  26
  27 package B2;
  28 use fields '_b1';
  29 use fields qw(b1 _b2 b2);
  30
  31 sub new { fields::new(shift); }
  32
  33 package D1;
  34 use base 'B1';
  35 use fields qw(d1 d2 d3);
  36
  37 package D2;
  38 use base 'B1';
  39 use fields qw(_d1 _d2);
  40 use fields qw(d1 d2);
  41
  42 package D3;
  43 use base 'B2';
  44 use fields qw(b1 d1 _b1 _d1);  # hide b1
  45
  46 package D4;
  47 use base 'D3';
  48 use fields qw(_d3 d3);
  49
  50 package M;
  51 sub m {}
  52
  53 package D5;
  54 use base qw(M B2);
  55
  56 package Foo::Bar;
  57 use base 'B1';
  58
  59 package Foo::Bar::Baz;
  60 use base 'Foo::Bar';
  61 use fields qw(foo bar baz);
  62
  63 # Test repeatability for when modules get reloaded.
  64 package B1;
  65 use fields qw(b1 b2 b3);
  66
  67 package D3;
  68 use base 'B2';
  69 use fields qw(b1 d1 _b1 _d1);  # hide b1
  70
  71 package main;
  72
  73 sub fstr {
  74    my $h = shift;
  75    my @tmp;
  76    for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) {
  77         my $v = $h->{$k};
  78         push(@tmp, "$k:$v");
  79    }
  80    my $str = join(",", @tmp);
  81    print "$h => $str\n" if $DEBUG;
  82    $str;
  83 }
  84
  85 my %expect = (
  86     B1 => "b1:1,b2:2,b3:3",
  87     B2 => "_b1:1,b1:2,_b2:3,b2:4",
  88     D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6",
  89     D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7",
  90     D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8",
  91     D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10",
  92     D5 => "b1:2,b2:4",
  93     'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6',
  94 );
  95
  96 plan tests => keys(%expect) + 17;
  97 my $testno = 0;
  98 while (my($class, $exp) = each %expect) {
  99    no strict 'refs';
 100    my $fstr = fstr(\%{$class."::FIELDS"});
 101    is( $fstr, $exp, "\%FIELDS check for $class" );
 102 }
 103
 104 # Did we get the appropriate amount of warnings?
 105 is( $w, 1 );
 106
 107 # A simple object creation and AVHV attribute access test
 108 my B2 $obj1 = D3->new;
 109 $obj1->{b1} = "B2";
 110 my D3 $obj2 = $obj1;
 111 $obj2->{b1} = "D3";
 112
 113 # We should get compile time failures field name typos
 114 eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = "");
 115 like $@, qr/^Attempt to access disallowed key 'notthere' in a restricted hash/;
 116
 117 # Slices
 118 @$obj1{"_b1", "b1"} = (17, 29);
 119 is_deeply($obj1, { b1 => 29, _b1 => 17 });
 120
 121 @$obj1{'_b1', 'b1'} = (44,28);
 122 is_deeply($obj1, { b1 => 28, _b1 => 44 });
 123
 124 eval { fields::phash };
 125 like $@, qr/^Pseudo-hashes have been removed from Perl/;
 126
 127 #fields::_dump();
 128
 129 # check if fields autovivify
 130 {
 131     package Foo;
 132     use fields qw(foo bar);
 133     sub new { fields::new($_[0]) }
 134
 135     package main;
 136     my Foo $a = Foo->new();
 137     $a->{foo} = ['a', 'ok', 'c'];
 138     $a->{bar} = { A => 'ok' };
 139     is( $a->{foo}[1],    'ok' );
 140     is( $a->{bar}->{A},, 'ok' );
 141 }
 142
 143 # check if fields autovivify
 144 {
 145     package Bar;
 146     use fields qw(foo bar);
 147     sub new { return fields::new($_[0]) }
 148
 149     package main;
 150     my Bar $a = Bar::->new();
 151     $a->{foo} = ['a', 'ok', 'c'];
 152     $a->{bar} = { A => 'ok' };
 153     is( $a->{foo}[1], 'ok' );
 154     is( $a->{bar}->{A}, 'ok' );
 155 }
 156
 157
 158 # Test $VERSION bug
 159 package No::Version;
 160
 161 use vars qw($Foo);
 162 sub VERSION { 42 }
 163
 164 package Test::Version;
 165
 166 use base qw(No::Version);
 167 ::like( $No::Version::VERSION, qr/set by base.pm/ );
 168
 169 # Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION
 170 package Has::Version;
 171
 172 BEGIN { $Has::Version::VERSION = '42' };
 173
 174 package Test::Version2;
 175
 176 use base qw(Has::Version);
 177 ::is( $Has::Version::VERSION, 42 );
 178
 179 package main;
 180
 181 our $eval1 = q{
 182   {
 183     package Eval1;
 184     {
 185       package Eval2;
 186       use base 'Eval1';
 187       $Eval2::VERSION = "1.02";
 188     }
 189     $Eval1::VERSION = "1.01";
 190   }
 191 };
 192
 193 eval $eval1;
 194 is( $@, '' );
 195
 196 is( $Eval1::VERSION, 1.01 );
 197
 198 is( $Eval2::VERSION, 1.02 );
 199
 200
 201 eval q{use base reallyReAlLyNotexists;};
 202 like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./,
 203                                           'base with empty package');
 204
 205 eval q{use base reallyReAlLyNotexists;};
 206 like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./,
 207                                           '  still empty on 2nd load');
 208
 209 BEGIN { $Has::Version_0::VERSION = 0 }
 210
 211 package Test::Version3;
 212
 213 use base qw(Has::Version_0);
 214 ::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' );
 215