This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to base 2.02.
[perl5.git] / lib / fields-base.t
1 #!/usr/bin/perl -w
2
3 my $Has_PH;
4 BEGIN { 
5     $Has_PH = $] < 5.009;
6 }
7
8 my $W;
9
10 BEGIN {
11     $W = 0;
12     $SIG{__WARN__} = sub {
13         if ($_[0] =~ /^Hides field '.*?' in base class/) {
14             $W++;
15         }
16         else {
17             warn $_[0];
18         }
19     };
20 }
21
22 use strict;
23 use Test::More tests => 29;
24
25 BEGIN { use_ok('base'); }
26
27 package B1;
28 use fields qw(b1 b2 b3);
29
30 package B2;
31 use fields '_b1';
32 use fields qw(b1 _b2 b2);
33
34 sub new { fields::new(shift) }
35
36 package B3;
37 use fields qw(b4 _b5 b6 _b7);
38
39 package D1;
40 use base 'B1';
41 use fields qw(d1 d2 d3);
42
43 package D2;
44 use base 'B1';
45 use fields qw(_d1 _d2);
46 use fields qw(d1 d2);
47
48
49 package D3;
50 use base 'B2';
51 use fields qw(b1 d1 _b1 _d1);  # hide b1
52
53 package D4;
54 use base 'D3';
55 use fields qw(_d3 d3);
56
57 package M;
58 sub m {}
59
60 package D5;
61 use base qw(M B2);
62
63 # Test that multiple inheritance fails.
64 package D6;
65 eval { 'base'->import(qw(B2 M B3)); };
66 ::like($@, qr/can't multiply inherit %FIELDS/i, 
67                                         'No multiple field inheritance');
68
69 package Foo::Bar;
70 use base 'B1';
71
72 package Foo::Bar::Baz;
73 use base 'Foo::Bar';
74 use fields qw(foo bar baz);
75
76 # Test repeatability for when modules get reloaded.
77 package B1;
78 use fields qw(b1 b2 b3);
79
80 package D3;
81 use base 'B2';
82 use fields qw(b1 d1 _b1 _d1);  # hide b1
83
84
85 package main;
86
87 my %EXPECT = (
88               B1 => [qw(b1 b2 b3)],
89               D1 => [qw(b1 b2 b3 d1 d2 d3)],
90               D2 => [qw(b1 b2 b3 _d1 _d2 d1 d2)],
91
92               M  => [qw()],
93               B2 => [qw(_b1 b1 _b2 b2)],
94               D3 => [(undef,undef,undef,
95                                 qw(b2 b1 d1 _b1 _d1))],     # b1 is hidden
96               D4 => [(undef,undef,undef,
97                                 qw(b2 b1 d1),undef,undef,qw(_d3 d3))],
98               D5 => [undef, 'b1', undef, 'b2'],
99
100               B3 => [qw(b4 _b5 b6 _b7)],
101
102               'Foo::Bar'        => [qw(b1 b2 b3)],
103               'Foo::Bar::Baz'   => [qw(b1 b2 b3 foo bar baz)],
104              );
105
106 while(my($class, $efields) = each %EXPECT) {
107     no strict 'refs';
108     my %fields = %{$class.'::FIELDS'};
109     my %expected_fields;
110     foreach my $idx (1..@$efields) {
111         my $key = $efields->[$idx-1];
112         next unless $key;
113         $expected_fields{$key} = $idx;
114     }
115
116     ::is_deeply(\%fields, \%expected_fields, "%FIELDS check:  $class");
117 }
118
119 # Did we get the appropriate amount of warnings?
120 is( $W, 1, 'right warnings' );
121
122
123 # A simple object creation and attribute access test
124 my B2 $obj1 = D3->new;
125 $obj1->{b1} = "B2";
126 my D3 $obj2 = $obj1;
127 $obj2->{b1} = "D3";
128
129 # We should get compile time failures field name typos
130 eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = "");
131 if( $Has_PH ) {
132     like $@, 
133       qr/^No such pseudo-hash field "notthere" in variable \$obj3 of type D3/;
134 }
135 else {
136     like $@, 
137       qr/^Attempt to access disallowed key 'notthere' in a restricted hash/;
138 }
139
140 # Slices
141 @$obj1{"_b1", "b1"} = (17, 29);
142 is( $obj1->{_b1}, 17 );
143 is( $obj1->{b1},  29 );
144
145 @$obj1{'_b1', 'b1'} = (44,28);
146 is( $obj1->{_b1}, 44 );
147 is( $obj1->{b1},  28 );
148
149
150
151 # Break multiple inheritance with a field name clash.
152 package E1;
153 use fields qw(yo this _lah meep 42);
154
155 package E2;
156 use fields qw(_yo ahhh this);
157
158 eval {
159     package Broken;
160
161     # The error must occur at run time for the eval to catch it.
162     require base;
163     'base'->import(qw(E1 E2));
164 };
165 ::like( $@, qr/Can't multiply inherit %FIELDS/i, 'Again, no multi inherit' );
166
167
168 package No::Version;
169
170 use vars qw($Foo);
171 sub VERSION { 42 }
172
173 package Test::Version;
174
175 use base qw(No::Version);
176 ::ok( $No::Version::VERSION =~ /set by base\.pm/,          '$VERSION bug' );
177
178 # Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION
179 package Has::Version;
180
181 BEGIN { $Has::Version::VERSION = '42' };
182
183 package Test::Version2;
184
185 use base qw(Has::Version);
186 ::is( $Has::Version::VERSION, 42 );
187
188 package main;
189
190 our $eval1 = q{
191   {
192     package Eval1;
193     {
194       package Eval2;
195       use base 'Eval1';
196       $Eval2::VERSION = "1.02";
197     }
198     $Eval1::VERSION = "1.01";
199   }
200 };
201
202 eval $eval1;
203 is( $@, '' );
204
205 is( $Eval1::VERSION, 1.01 );
206
207 is( $Eval2::VERSION, 1.02 );
208
209
210 eval q{use base 'reallyReAlLyNotexists'};
211 like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./,
212                                           'base with empty package');
213
214 eval q{use base 'reallyReAlLyNotexists'};
215 like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./,
216                                           '  still empty on 2nd load');
217
218 BEGIN { $Has::Version_0::VERSION = 0 }
219
220 package Test::Version3;
221
222 use base qw(Has::Version_0);
223 ::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' );
224
225
226 package Test::SIGDIE;
227
228
229     local $SIG{__DIE__} = sub { 
230         ::fail('sigdie not caught, this test should not run') 
231     };
232     eval {
233       'base'->import(qw(Huh::Boo));
234     };
235
236     ::like($@, qr/^Base class package "Huh::Boo" is empty/, 
237          'Base class empty error message');
238
239 }