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