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