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 | } | |
803b07a7 | 13 | print STDERR $_[0]; |
f1192cee GA |
14 | }; |
15 | } | |
16 | ||
b47ba5cf | 17 | use strict; |
9f1b1f2d | 18 | use warnings; |
b47ba5cf GS |
19 | use vars qw($DEBUG); |
20 | ||
6d822dc4 MS |
21 | use Test::More; |
22 | ||
23 | ||
f1192cee GA |
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 | ||
6d822dc4 | 31 | sub new { fields::new(shift); } |
f1192cee GA |
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 | ||
f30a1143 JT |
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 | ||
f1192cee GA |
71 | package main; |
72 | ||
479ba383 | 73 | sub fstr { |
f1192cee GA |
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 | ||
0ea4badc JH |
96 | plan tests => keys(%expect) + 21; |
97 | ||
f1192cee | 98 | my $testno = 0; |
0ea4badc | 99 | |
f1192cee GA |
100 | while (my($class, $exp) = each %expect) { |
101 | no strict 'refs'; | |
102 | my $fstr = fstr(\%{$class."::FIELDS"}); | |
6d822dc4 | 103 | is( $fstr, $exp, "\%FIELDS check for $class" ); |
f1192cee GA |
104 | } |
105 | ||
106 | # Did we get the appropriate amount of warnings? | |
6d822dc4 | 107 | is( $w, 1 ); |
f1192cee GA |
108 | |
109 | # A simple object creation and AVHV attribute access test | |
110 | my B2 $obj1 = D3->new; | |
111 | $obj1->{b1} = "B2"; | |
112 | my D3 $obj2 = $obj1; | |
113 | $obj2->{b1} = "D3"; | |
114 | ||
f1192cee GA |
115 | # We should get compile time failures field name typos |
116 | eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); | |
6d822dc4 | 117 | like $@, qr/^Attempt to access disallowed key 'notthere' in a restricted hash/; |
f1192cee | 118 | |
345599ca GS |
119 | # Slices |
120 | @$obj1{"_b1", "b1"} = (17, 29); | |
6d822dc4 | 121 | is_deeply($obj1, { b1 => 29, _b1 => 17 }); |
479ba383 | 122 | |
6d822dc4 MS |
123 | @$obj1{'_b1', 'b1'} = (44,28); |
124 | is_deeply($obj1, { b1 => 28, _b1 => 44 }); | |
479ba383 | 125 | |
6d822dc4 MS |
126 | eval { fields::phash }; |
127 | like $@, qr/^Pseudo-hashes have been removed from Perl/; | |
479ba383 | 128 | |
f1192cee | 129 | #fields::_dump(); |
377b21bb | 130 | |
479ba383 | 131 | # check if fields autovivify |
377b21bb GS |
132 | { |
133 | package Foo; | |
134 | use fields qw(foo bar); | |
6d822dc4 | 135 | sub new { fields::new($_[0]) } |
377b21bb GS |
136 | |
137 | package main; | |
138 | my Foo $a = Foo->new(); | |
6d822dc4 MS |
139 | $a->{foo} = ['a', 'ok', 'c']; |
140 | $a->{bar} = { A => 'ok' }; | |
141 | is( $a->{foo}[1], 'ok' ); | |
142 | is( $a->{bar}->{A},, 'ok' ); | |
377b21bb | 143 | } |
479ba383 GS |
144 | |
145 | # check if fields autovivify | |
146 | { | |
147 | package Bar; | |
148 | use fields qw(foo bar); | |
149 | sub new { return fields::new($_[0]) } | |
150 | ||
151 | package main; | |
152 | my Bar $a = Bar::->new(); | |
6d822dc4 MS |
153 | $a->{foo} = ['a', 'ok', 'c']; |
154 | $a->{bar} = { A => 'ok' }; | |
155 | is( $a->{foo}[1], 'ok' ); | |
156 | is( $a->{bar}->{A}, 'ok' ); | |
479ba383 | 157 | } |
2bc5db75 MS |
158 | |
159 | ||
160 | # Test $VERSION bug | |
161 | package No::Version; | |
162 | ||
163 | use vars qw($Foo); | |
164 | sub VERSION { 42 } | |
165 | ||
166 | package Test::Version; | |
167 | ||
168 | use base qw(No::Version); | |
6d822dc4 | 169 | ::like( $No::Version::VERSION, qr/set by base.pm/ ); |
e8f84f55 NIS |
170 | |
171 | # Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION | |
172 | package Has::Version; | |
173 | ||
174 | BEGIN { $Has::Version::VERSION = '42' }; | |
175 | ||
176 | package Test::Version2; | |
177 | ||
178 | use base qw(Has::Version); | |
6d822dc4 | 179 | ::is( $Has::Version::VERSION, 42 ); |
b94834e7 A |
180 | |
181 | package main; | |
182 | ||
183 | our $eval1 = q{ | |
184 | { | |
185 | package Eval1; | |
186 | { | |
187 | package Eval2; | |
188 | use base 'Eval1'; | |
189 | $Eval2::VERSION = "1.02"; | |
190 | } | |
191 | $Eval1::VERSION = "1.01"; | |
192 | } | |
193 | }; | |
194 | ||
195 | eval $eval1; | |
6d822dc4 | 196 | is( $@, '' ); |
b94834e7 | 197 | |
6d822dc4 | 198 | is( $Eval1::VERSION, 1.01 ); |
b94834e7 | 199 | |
6d822dc4 | 200 | is( $Eval2::VERSION, 1.02 ); |
b94834e7 A |
201 | |
202 | ||
7678c486 | 203 | eval q{use base 'reallyReAlLyNotexists'}; |
6d822dc4 MS |
204 | like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./, |
205 | 'base with empty package'); | |
b94834e7 | 206 | |
7678c486 | 207 | eval q{use base 'reallyReAlLyNotexists'}; |
6d822dc4 MS |
208 | like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./, |
209 | ' still empty on 2nd load'); | |
b94834e7 A |
210 | |
211 | BEGIN { $Has::Version_0::VERSION = 0 } | |
212 | ||
213 | package Test::Version3; | |
214 | ||
215 | use base qw(Has::Version_0); | |
6d822dc4 | 216 | ::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' ); |
e8f84f55 | 217 | |
0ea4badc JH |
218 | package Test::FooBar; |
219 | ||
220 | use fields qw(a b c); | |
221 | ||
222 | sub new { | |
223 | my $self = fields::new(shift); | |
224 | %$self = @_ if @_; | |
225 | $self; | |
226 | } | |
227 | ||
228 | package main; | |
229 | ||
230 | { | |
231 | my $x = Test::FooBar->new( a => 1, b => 2); | |
232 | ||
233 | is(ref $x, 'Test::FooBar', 'x is a Test::FooBar'); | |
234 | ok(exists $x->{a}, 'x has a'); | |
235 | ok(exists $x->{b}, 'x has b'); | |
236 | is(scalar keys %$x, 2, 'x has two fields'); | |
237 | } | |
238 | ||
239 |