Commit | Line | Data |
f1192cee |
1 | #!./perl -w |
2 | |
f1192cee |
3 | my $w; |
4 | |
5 | BEGIN { |
11162842 |
6 | chdir 't' if -d 't'; |
93430cb4 |
7 | unshift @INC, '../lib' if -d '../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; |
18 | use vars qw($DEBUG); |
19 | |
f1192cee |
20 | package B1; |
21 | use fields qw(b1 b2 b3); |
22 | |
23 | package B2; |
24 | use fields '_b1'; |
25 | use fields qw(b1 _b2 b2); |
26 | |
27 | sub new { bless [], shift } |
28 | |
29 | package D1; |
30 | use base 'B1'; |
31 | use fields qw(d1 d2 d3); |
32 | |
33 | package D2; |
34 | use base 'B1'; |
35 | use fields qw(_d1 _d2); |
36 | use fields qw(d1 d2); |
37 | |
38 | package D3; |
39 | use base 'B2'; |
40 | use fields qw(b1 d1 _b1 _d1); # hide b1 |
41 | |
42 | package D4; |
43 | use base 'D3'; |
44 | use fields qw(_d3 d3); |
45 | |
46 | package M; |
47 | sub m {} |
48 | |
49 | package D5; |
50 | use base qw(M B2); |
51 | |
52 | package Foo::Bar; |
53 | use base 'B1'; |
54 | |
55 | package Foo::Bar::Baz; |
56 | use base 'Foo::Bar'; |
57 | use fields qw(foo bar baz); |
58 | |
f30a1143 |
59 | # Test repeatability for when modules get reloaded. |
60 | package B1; |
61 | use fields qw(b1 b2 b3); |
62 | |
63 | package D3; |
64 | use base 'B2'; |
65 | use fields qw(b1 d1 _b1 _d1); # hide b1 |
66 | |
f1192cee |
67 | package main; |
68 | |
479ba383 |
69 | sub fstr { |
f1192cee |
70 | my $h = shift; |
71 | my @tmp; |
72 | for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { |
73 | my $v = $h->{$k}; |
74 | push(@tmp, "$k:$v"); |
75 | } |
76 | my $str = join(",", @tmp); |
77 | print "$h => $str\n" if $DEBUG; |
78 | $str; |
79 | } |
80 | |
81 | my %expect = ( |
82 | B1 => "b1:1,b2:2,b3:3", |
83 | B2 => "_b1:1,b1:2,_b2:3,b2:4", |
84 | D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6", |
85 | D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7", |
86 | D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8", |
87 | D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10", |
88 | D5 => "b1:2,b2:4", |
89 | 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', |
90 | ); |
91 | |
479ba383 |
92 | print "1..", int(keys %expect)+13, "\n"; |
f1192cee |
93 | my $testno = 0; |
94 | while (my($class, $exp) = each %expect) { |
95 | no strict 'refs'; |
96 | my $fstr = fstr(\%{$class."::FIELDS"}); |
97 | print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp; |
98 | print "ok ", ++$testno, "\n"; |
99 | } |
100 | |
101 | # Did we get the appropriate amount of warnings? |
102 | print "not " unless $w == 1; |
103 | print "ok ", ++$testno, "\n"; |
104 | |
105 | # A simple object creation and AVHV attribute access test |
106 | my B2 $obj1 = D3->new; |
107 | $obj1->{b1} = "B2"; |
108 | my D3 $obj2 = $obj1; |
109 | $obj2->{b1} = "D3"; |
110 | |
111 | print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3"; |
112 | print "ok ", ++$testno, "\n"; |
113 | |
114 | # We should get compile time failures field name typos |
115 | eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); |
ae9a5a84 |
116 | print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/; |
f1192cee |
117 | print "ok ", ++$testno, "\n"; |
118 | |
345599ca |
119 | # Slices |
120 | @$obj1{"_b1", "b1"} = (17, 29); |
121 | print "not " unless "@$obj1[1,2]" eq "17 29"; |
122 | print "ok ", ++$testno, "\n"; |
123 | @$obj1[1,2] = (44,28); |
124 | print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28"; |
125 | print "ok ", ++$testno, "\n"; |
126 | |
479ba383 |
127 | my $ph = fields::phash(a => 1, b => 2, c => 3); |
128 | print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; |
129 | print "ok ", ++$testno, "\n"; |
130 | |
131 | $ph = fields::phash([qw/a b c/], [1, 2, 3]); |
132 | print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; |
133 | print "ok ", ++$testno, "\n"; |
134 | |
135 | $ph = fields::phash([qw/a b c/], [1]); |
136 | print "not " if exists $ph->{b} or exists $ph->{c} or !exists $ph->{a}; |
137 | print "ok ", ++$testno, "\n"; |
138 | |
139 | eval '$ph = fields::phash("odd")'; |
140 | print "not " unless $@ && $@ =~ /^Odd number of/; |
141 | print "ok ", ++$testno, "\n"; |
142 | |
f1192cee |
143 | #fields::_dump(); |
377b21bb |
144 | |
479ba383 |
145 | # check if fields autovivify |
377b21bb |
146 | { |
147 | package Foo; |
148 | use fields qw(foo bar); |
149 | sub new { bless [], $_[0]; } |
150 | |
151 | package main; |
152 | my Foo $a = Foo->new(); |
153 | $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; |
154 | $a->{bar} = { A => 'ok ' . ++$testno }; |
155 | print $a->{foo}[1], "\n"; |
156 | print $a->{bar}->{A}, "\n"; |
157 | } |
479ba383 |
158 | |
159 | # check if fields autovivify |
160 | { |
161 | package Bar; |
162 | use fields qw(foo bar); |
163 | sub new { return fields::new($_[0]) } |
164 | |
165 | package main; |
166 | my Bar $a = Bar::->new(); |
167 | $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; |
168 | $a->{bar} = { A => 'ok ' . ++$testno }; |
169 | print $a->{foo}[1], "\n"; |
170 | print $a->{bar}->{A}, "\n"; |
171 | } |