t/lib/fields.t

   1 #!./perl -w
   2
   3 use strict;
   4 use vars qw($DEBUG);
   5
   6 my $w;
   7
   8 BEGIN {
   9    $SIG{__WARN__} = sub {
  10        if ($_[0] =~ /^Hides field 'b1' in base class/) {
  11            $w++;
  12            return;
  13        }
  14        print $_[0];
  15    };
  16 }
  17
  18 package B1;
  19 use fields qw(b1 b2 b3);
  20
  21 package B2;
  22 use fields '_b1';
  23 use fields qw(b1 _b2 b2);
  24
  25 sub new { bless [], shift }
  26
  27 package D1;
  28 use base 'B1';
  29 use fields qw(d1 d2 d3);
  30
  31 package D2;
  32 use base 'B1';
  33 use fields qw(_d1 _d2);
  34 use fields qw(d1 d2);
  35
  36 package D3;
  37 use base 'B2';
  38 use fields qw(b1 d1 _b1 _d1);  # hide b1
  39
  40 package D4;
  41 use base 'D3';
  42 use fields qw(_d3 d3);
  43
  44 package M;
  45 sub m {}
  46
  47 package D5;
  48 use base qw(M B2);
  49
  50 package Foo::Bar;
  51 use base 'B1';
  52
  53 package Foo::Bar::Baz;
  54 use base 'Foo::Bar';
  55 use fields qw(foo bar baz);
  56
  57 package main;
  58
  59 sub fstr
  60 {
  61    my $h = shift;
  62    my @tmp;
  63    for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) {
  64         my $v = $h->{$k};
  65         push(@tmp, "$k:$v");
  66    }
  67    my $str = join(",", @tmp);
  68    print "$h => $str\n" if $DEBUG;
  69    $str;
  70 }
  71
  72 my %expect = (
  73     B1 => "b1:1,b2:2,b3:3",
  74     B2 => "_b1:1,b1:2,_b2:3,b2:4",
  75     D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6",
  76     D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7",
  77     D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8",
  78     D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10",
  79     D5 => "b1:2,b2:4",
  80     'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6',
  81 );
  82
  83 print "1..", int(keys %expect)+3, "\n";
  84 my $testno = 0;
  85 while (my($class, $exp) = each %expect) {
  86    no strict 'refs';
  87    my $fstr = fstr(\%{$class."::FIELDS"});
  88    print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp;
  89    print "ok ", ++$testno, "\n";
  90 }
  91
  92 # Did we get the appropriate amount of warnings?
  93 print "not " unless $w == 1;
  94 print "ok ", ++$testno, "\n";
  95
  96 # A simple object creation and AVHV attribute access test
  97 my B2 $obj1 = D3->new;
  98 $obj1->{b1} = "B2";
  99 my D3 $obj2 = $obj1;
 100 $obj2->{b1} = "D3";
 101
 102 print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3";
 103 print "ok ", ++$testno, "\n";
 104
 105 # We should get compile time failures field name typos
 106 eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = "");
 107 print "not " unless $@ && $@ =~ /^No such field "notthere"/;
 108 print "ok ", ++$testno, "\n";
 109
 110 #fields::_dump();