Commit | Line | Data |
---|---|---|
f1192cee GA |
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(); |