This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to base and fields 2.12, mostly by Michael G Schwern
[perl5.git] / lib / base / t / fields-base.t
CommitLineData
33d611b9
JH
1#!/usr/bin/perl -w
2
e75d1f10 3my ($Has_PH, $Field);
33d611b9
JH
4BEGIN {
5 $Has_PH = $] < 5.009;
e75d1f10 6 $Field = $Has_PH ? "pseudo-hash field" : "class field";
33d611b9
JH
7}
8
9my $W;
10
11BEGIN {
12 $W = 0;
13 $SIG{__WARN__} = sub {
14 if ($_[0] =~ /^Hides field '.*?' in base class/) {
15 $W++;
16 }
17 else {
18 warn $_[0];
19 }
20 };
21}
22
23use strict;
85be41dd 24use Test::More tests => 29;
33d611b9
JH
25
26BEGIN { use_ok('base'); }
27
28package B1;
29use fields qw(b1 b2 b3);
30
31package B2;
32use fields '_b1';
33use fields qw(b1 _b2 b2);
34
35sub new { fields::new(shift) }
36
37package B3;
38use fields qw(b4 _b5 b6 _b7);
39
40package D1;
41use base 'B1';
42use fields qw(d1 d2 d3);
43
44package D2;
45use base 'B1';
46use fields qw(_d1 _d2);
47use fields qw(d1 d2);
48
49
50package D3;
51use base 'B2';
52use fields qw(b1 d1 _b1 _d1); # hide b1
53
54package D4;
55use base 'D3';
56use fields qw(_d3 d3);
57
58package M;
59sub m {}
60
61package D5;
62use base qw(M B2);
63
64# Test that multiple inheritance fails.
65package D6;
66eval { 'base'->import(qw(B2 M B3)); };
9e998a43
RGS
67::like($@, qr/can't multiply inherit fields/i,
68 'No multiple field inheritance');
33d611b9
JH
69
70package Foo::Bar;
71use base 'B1';
72
73package Foo::Bar::Baz;
74use base 'Foo::Bar';
75use fields qw(foo bar baz);
76
77# Test repeatability for when modules get reloaded.
78package B1;
79use fields qw(b1 b2 b3);
80
81package D3;
82use base 'B2';
83use fields qw(b1 d1 _b1 _d1); # hide b1
84
85
864f8ab4
JH
86# Test that a package with only private fields gets inherited properly
87package B7;
88use fields qw(_b1);
89
90package D7;
91use base qw(B7);
92use fields qw(b1);
93
94
95# Test that an intermediate package with no fields doesn't cause a problem.
96package B8;
97use fields qw(_b1);
98
99package D8;
100use base qw(B8);
101
102package D8A;
103use base qw(D8);
104use fields qw(b1);
105
106
33d611b9
JH
107package main;
108
109my %EXPECT = (
110 B1 => [qw(b1 b2 b3)],
111 D1 => [qw(b1 b2 b3 d1 d2 d3)],
112 D2 => [qw(b1 b2 b3 _d1 _d2 d1 d2)],
113
114 M => [qw()],
115 B2 => [qw(_b1 b1 _b2 b2)],
116 D3 => [(undef,undef,undef,
117 qw(b2 b1 d1 _b1 _d1))], # b1 is hidden
118 D4 => [(undef,undef,undef,
119 qw(b2 b1 d1),undef,undef,qw(_d3 d3))],
864f8ab4 120
33d611b9
JH
121 D5 => [undef, 'b1', undef, 'b2'],
122
123 B3 => [qw(b4 _b5 b6 _b7)],
124
864f8ab4
JH
125 B7 => [qw(_b1)],
126 D7 => [undef, 'b1'],
127
128 B8 => [qw(_b1)],
129 D8 => [undef],
130 D8A => [undef, 'b1'],
131
33d611b9
JH
132 'Foo::Bar' => [qw(b1 b2 b3)],
133 'Foo::Bar::Baz' => [qw(b1 b2 b3 foo bar baz)],
134 );
135
136while(my($class, $efields) = each %EXPECT) {
137 no strict 'refs';
138 my %fields = %{$class.'::FIELDS'};
139 my %expected_fields;
140 foreach my $idx (1..@$efields) {
141 my $key = $efields->[$idx-1];
142 next unless $key;
143 $expected_fields{$key} = $idx;
144 }
145
146 ::is_deeply(\%fields, \%expected_fields, "%FIELDS check: $class");
147}
148
149# Did we get the appropriate amount of warnings?
150is( $W, 1, 'right warnings' );
151
152
153# A simple object creation and attribute access test
154my B2 $obj1 = D3->new;
155$obj1->{b1} = "B2";
156my D3 $obj2 = $obj1;
157$obj2->{b1} = "D3";
158
159# We should get compile time failures field name typos
e75d1f10
RD
160eval q(return; my D3 $obj3 = $obj2; $obj3->{notthere} = "");
161like $@,
162 qr/^No such $Field "notthere" in variable \$obj3 of type D3/,
163 "Compile failure of undeclared fields (helem)";
33d611b9
JH
164
165# Slices
e75d1f10
RD
166# We should get compile time failures field name typos
167eval q(return; my D3 $obj3 = $obj2; my $k; @$obj3{$k,'notthere'} = ());
168like $@,
169 qr/^No such $Field "notthere" in variable \$obj3 of type D3/,
170 "Compile failure of undeclared fields (hslice)";
171eval q(return; my D3 $obj3 = $obj2; my $k; @{$obj3}{$k,'notthere'} = ());
172like
173 $@, qr/^No such $Field "notthere" in variable \$obj3 of type D3/,
174 "Compile failure of undeclared fields (hslice (block form))";
175
33d611b9
JH
176@$obj1{"_b1", "b1"} = (17, 29);
177is( $obj1->{_b1}, 17 );
178is( $obj1->{b1}, 29 );
179
180@$obj1{'_b1', 'b1'} = (44,28);
181is( $obj1->{_b1}, 44 );
182is( $obj1->{b1}, 28 );
183
184
185
186# Break multiple inheritance with a field name clash.
187package E1;
188use fields qw(yo this _lah meep 42);
189
190package E2;
191use fields qw(_yo ahhh this);
192
193eval {
194 package Broken;
195
196 # The error must occur at run time for the eval to catch it.
197 require base;
198 'base'->import(qw(E1 E2));
199};
9e998a43 200::like( $@, qr/Can't multiply inherit fields/i, 'Again, no multi inherit' );
33d611b9
JH
201
202
8731c5d9 203# Test that a package with no fields can inherit from a package with
204# fields, and that pseudohash messages don't show up
205
206package B9;
207use fields qw(b1);
208
209sub _mk_obj { fields::new($_[0])->{'b1'} };
210
211package D9;
212use base qw(B9);
213
214package main;
215
216{
217 my $w = 0;
218 local $SIG{__WARN__} = sub { $w++ };
219
220 B9->_mk_obj();
221 # used tp emit a warning that pseudohashes are deprecated, because
222 # %FIELDS wasn't blessed.
223 D9->_mk_obj();
224
225 is ($w, 0, "pseudohash warnings in derived class with no fields of it's own");
226}
85be41dd
DM
227
228# [perl #31078] an intermediate class with no additional fields caused
229# hidden fields in base class to get stomped on
230
231{
232 package X;
233 use fields qw(X1 _X2);
234 sub new {
235 my X $self = shift;
236 $self = fields::new($self) unless ref $self;
237 $self->{X1} = "x1";
4946def6
NC
238 # FIXME. This code is dead on blead becase the test is skipped.
239 # The test states that it's being skipped becaues restricted hashes
240 # don't support a feature. Presumably we need to make that feature
241 # supported. Bah.
242 # use Devel::Peek; Dump($self);
85be41dd
DM
243 $self->{_X2} = "_x2";
244 return $self;
245 }
246 sub get_X2 { my X $self = shift; $self->{_X2} }
247
248 package Y;
249 use base qw(X);
250
251 sub new {
252 my Y $self = shift;
253 $self = fields::new($self) unless ref $self;
254 $self->SUPER::new();
255 return $self;
256 }
257
258
259 package Z;
260 use base qw(Y);
261 use fields qw(Z1);
262
263 sub new {
264 my Z $self = shift;
265 $self = fields::new($self) unless ref $self;
266 $self->SUPER::new();
267 $self->{Z1} = 'z1';
268 return $self;
269 }
270
271 package main;
272
273 if ($Has_PH) {
274 my Z $c = Z->new();
275 is($c->get_X2, '_x2', "empty intermediate class");
276 }
277 else {
278 SKIP: {
279 skip "restricted hashes don't support private fields properly", 1;
280 }
281 }
282}