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