Commit | Line | Data |
024bc14b |
1 | # The fields.pm and base.pm regression tests from 5.6.0 |
2 | |
3 | # We skip this on 5.9.0 and up since pseudohashes were removed and a lot |
4 | # of it won't work. |
5 | if( $] >= 5.009 ) { |
6 | print "1..0 # skip pseudo-hashes removed in 5.9.0\n"; |
7 | exit; |
8 | } |
9 | |
10 | use strict; |
11 | use vars qw($Total_tests); |
12 | |
13 | my $test_num = 1; |
14 | BEGIN { $| = 1; $^W = 1; } |
15 | print "1..$Total_tests\n"; |
16 | use fields; |
17 | use base; |
18 | print "ok $test_num\n"; |
19 | $test_num++; |
20 | |
21 | # Insert your test code below (better if it prints "ok 13" |
22 | # (correspondingly "not ok 13") depending on the success of chunk 13 |
23 | # of the test code): |
24 | sub ok { |
25 | my($test, $name) = @_; |
26 | print "not " unless $test; |
27 | print "ok $test_num"; |
28 | print " - $name" if defined $name; |
29 | print "\n"; |
30 | $test_num++; |
31 | } |
32 | |
33 | sub eqarray { |
34 | my($a1, $a2) = @_; |
35 | return 0 unless @$a1 == @$a2; |
36 | my $ok = 1; |
37 | for (0..$#{$a1}) { |
38 | unless($a1->[$_] eq $a2->[$_]) { |
39 | $ok = 0; |
40 | last; |
41 | } |
42 | } |
43 | return $ok; |
44 | } |
45 | |
46 | # Change this to your # of ok() calls + 1 |
47 | BEGIN { $Total_tests = 14 } |
48 | |
49 | |
50 | my $w; |
51 | |
52 | BEGIN { |
53 | $^W = 1; |
54 | |
55 | $SIG{__WARN__} = sub { |
56 | if ($_[0] =~ /^Hides field 'b1' in base class/) { |
57 | $w++; |
58 | return; |
59 | } |
036549e3 |
60 | if ($_[0] =~ /^Pseudo-hashes are deprecated/ && |
61 | ($] >= 5.008 && $] < 5.009)) { |
62 | print "# $_[0]"; # Yes, we know they are deprecated. |
63 | return; |
64 | } |
024bc14b |
65 | print $_[0]; |
66 | }; |
67 | } |
68 | |
69 | use strict; |
70 | use vars qw($DEBUG); |
71 | |
72 | package B1; |
73 | use fields qw(b1 b2 b3); |
74 | |
75 | package B2; |
76 | use fields '_b1'; |
77 | use fields qw(b1 _b2 b2); |
78 | |
79 | sub new { bless [], shift } |
80 | |
81 | package D1; |
82 | use base 'B1'; |
83 | use fields qw(d1 d2 d3); |
84 | |
85 | package D2; |
86 | use base 'B1'; |
87 | use fields qw(_d1 _d2); |
88 | use fields qw(d1 d2); |
89 | |
90 | package D3; |
91 | use base 'B2'; |
92 | use fields qw(b1 d1 _b1 _d1); # hide b1 |
93 | |
94 | package D4; |
95 | use base 'D3'; |
96 | use fields qw(_d3 d3); |
97 | |
98 | package M; |
99 | sub m {} |
100 | |
101 | package D5; |
102 | use base qw(M B2); |
103 | |
104 | package Foo::Bar; |
105 | use base 'B1'; |
106 | |
107 | package Foo::Bar::Baz; |
108 | use base 'Foo::Bar'; |
109 | use fields qw(foo bar baz); |
110 | |
111 | # Test repeatability for when modules get reloaded. |
112 | package B1; |
113 | use fields qw(b1 b2 b3); |
114 | |
115 | package D3; |
116 | use base 'B2'; |
117 | use fields qw(b1 d1 _b1 _d1); # hide b1 |
118 | |
119 | package main; |
120 | |
121 | sub fstr { |
122 | my $h = shift; |
123 | my @tmp; |
124 | for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { |
125 | my $v = $h->{$k}; |
126 | push(@tmp, "$k:$v"); |
127 | } |
128 | my $str = join(",", @tmp); |
129 | print "$h => $str\n" if $DEBUG; |
130 | $str; |
131 | } |
132 | |
133 | my %expect; |
134 | BEGIN { |
135 | %expect = ( |
136 | B1 => "b1:1,b2:2,b3:3", |
137 | B2 => "_b1:1,b1:2,_b2:3,b2:4", |
138 | D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6", |
139 | D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7", |
140 | D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8", |
141 | D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10", |
142 | D5 => "b1:2,b2:4", |
143 | 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', |
144 | ); |
145 | $Total_tests += int(keys %expect); |
146 | } |
147 | my $testno = 0; |
148 | while (my($class, $exp) = each %expect) { |
149 | no strict 'refs'; |
150 | my $fstr = fstr(\%{$class."::FIELDS"}); |
151 | ok( $fstr eq $exp, "'$fstr' eq '$exp'" ); |
152 | } |
153 | |
154 | # Did we get the appropriate amount of warnings? |
155 | ok( $w == 1 ); |
156 | |
157 | # A simple object creation and AVHV attribute access test |
158 | my B2 $obj1 = D3->new; |
159 | $obj1->{b1} = "B2"; |
160 | my D3 $obj2 = $obj1; |
161 | $obj2->{b1} = "D3"; |
162 | |
163 | ok( $obj1->[2] eq "B2" && $obj1->[5] eq "D3" ); |
164 | |
165 | # We should get compile time failures field name typos |
166 | eval q{ my D3 $obj3 = $obj2; $obj3->{notthere} = "" }; |
167 | ok( $@ && $@ =~ /^No such pseudo-hash field "notthere"/, |
168 | 'compile error -- field name typos' ); |
169 | |
170 | |
171 | # Slices |
172 | if( $] >= 5.006 ) { |
173 | @$obj1{"_b1", "b1"} = (17, 29); |
174 | ok( "@$obj1[1,2]" eq "17 29" ); |
175 | |
176 | @$obj1[1,2] = (44,28); |
177 | ok( "@$obj1{'b1','_b1','b1'}" eq "28 44 28" ); |
178 | } |
179 | else { |
180 | ok( 1, 'test skipped for perl < 5.6.0' ); |
181 | ok( 1, 'test skipped for perl < 5.6.0' ); |
182 | } |
183 | |
184 | my $ph = fields::phash(a => 1, b => 2, c => 3); |
185 | ok( fstr($ph) eq 'a:1,b:2,c:3' ); |
186 | |
187 | $ph = fields::phash([qw/a b c/], [1, 2, 3]); |
188 | ok( fstr($ph) eq 'a:1,b:2,c:3' ); |
189 | |
190 | # The way exists() works with psuedohashes changed from 5.005 to 5.6 |
191 | $ph = fields::phash([qw/a b c/], [1]); |
192 | if( $] > 5.006 ) { |
193 | ok( !( exists $ph->{b} or exists $ph->{c} or !exists $ph->{a} ) ); |
194 | } |
195 | else { |
196 | ok( !( defined $ph->{b} or defined $ph->{c} or !defined $ph->{a} ) ); |
197 | } |
198 | |
199 | eval { $ph = fields::phash("odd") }; |
200 | ok( $@ && $@ =~ /^Odd number of/ ); |
201 | |
202 | |
203 | # check if fields autovivify |
204 | if ( $] > 5.006 ) { |
205 | package Foo; |
206 | use fields qw(foo bar); |
207 | sub new { bless [], $_[0]; } |
208 | |
209 | package main; |
210 | my Foo $a = Foo->new(); |
211 | $a->{foo} = ['a', 'ok', 'c']; |
212 | $a->{bar} = { A => 'ok' }; |
213 | ok( $a->{foo}[1] eq 'ok' ); |
214 | ok( $a->{bar}->{A} eq 'ok' ); |
215 | } |
216 | else { |
217 | ok( 1, 'test skipped for perl < 5.6.0' ); |
218 | ok( 1, 'test skipped for perl < 5.6.0' ); |
219 | } |
220 | |
221 | # check if fields autovivify |
222 | { |
223 | package Bar; |
224 | use fields qw(foo bar); |
225 | sub new { return fields::new($_[0]) } |
226 | |
227 | package main; |
228 | my Bar $a = Bar::->new(); |
229 | $a->{foo} = ['a', 'ok', 'c']; |
230 | $a->{bar} = { A => 'ok' }; |
231 | ok( $a->{foo}[1] eq 'ok' ); |
232 | ok( $a->{bar}->{A} eq 'ok' ); |
233 | } |