This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix @{*ISA} autovivification
[perl5.git] / t / mro / basic.t
1 #!./perl
2
3 use strict;
4 use warnings;
5
6 BEGIN { require q(./test.pl); } plan(tests => 54);
7
8 require mro;
9
10 {
11     package MRO_A;
12     our @ISA = qw//;
13     package MRO_B;
14     our @ISA = qw//;
15     package MRO_C;
16     our @ISA = qw//;
17     package MRO_D;
18     our @ISA = qw/MRO_A MRO_B MRO_C/;
19     package MRO_E;
20     our @ISA = qw/MRO_A MRO_B MRO_C/;
21     package MRO_F;
22     our @ISA = qw/MRO_D MRO_E/;
23 }
24
25 my @MFO_F_DFS = qw/MRO_F MRO_D MRO_A MRO_B MRO_C MRO_E/;
26 my @MFO_F_C3 = qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/;
27 is(mro::get_mro('MRO_F'), 'dfs');
28 ok(eq_array(
29     mro::get_linear_isa('MRO_F'), \@MFO_F_DFS
30 ));
31
32 ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS));
33 ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3));
34 eval{mro::get_linear_isa('MRO_F', 'C3')};
35 like($@, qr/^Invalid mro name: 'C3'/);
36
37 mro::set_mro('MRO_F', 'c3');
38 is(mro::get_mro('MRO_F'), 'c3');
39 ok(eq_array(
40     mro::get_linear_isa('MRO_F'), \@MFO_F_C3
41 ));
42
43 ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS));
44 ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3));
45 eval{mro::get_linear_isa('MRO_F', 'C3')};
46 like($@, qr/^Invalid mro name: 'C3'/);
47
48 my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')};
49 ok(eq_array(
50     \@isarev,
51     [qw/MRO_D MRO_E MRO_F/]
52 ));
53
54 ok(!mro::is_universal('MRO_B'));
55
56 @UNIVERSAL::ISA = qw/MRO_F/;
57 ok(mro::is_universal('MRO_B'));
58
59 @UNIVERSAL::ISA = ();
60 ok(!mro::is_universal('MRO_B'));
61
62 # is_universal, get_mro, and get_linear_isa should
63 # handle non-existent packages sanely
64 ok(!mro::is_universal('Does_Not_Exist'));
65 is(mro::get_mro('Also_Does_Not_Exist'), 'dfs');
66 ok(eq_array(
67     mro::get_linear_isa('Does_Not_Exist_Three'),
68     [qw/Does_Not_Exist_Three/]
69 ));
70
71 # Assigning @ISA via globref
72 {
73     package MRO_TestBase;
74     sub testfunc { return 123 }
75     package MRO_TestOtherBase;
76     sub testfunctwo { return 321 }
77     package MRO_M; our @ISA = qw/MRO_TestBase/;
78 }
79 *MRO_N::ISA = *MRO_M::ISA;
80 is(eval { MRO_N->testfunc() }, 123);
81
82 # XXX TODO (when there's a way to backtrack through a glob's aliases)
83 # push(@MRO_M::ISA, 'MRO_TestOtherBase');
84 # is(eval { MRO_N->testfunctwo() }, 321);
85
86 # Simple DESTROY Baseline
87 {
88     my $x = 0;
89     my $obj;
90
91     {
92         package DESTROY_MRO_Baseline;
93         sub new { bless {} => shift }
94         sub DESTROY { $x++ }
95
96         package DESTROY_MRO_Baseline_Child;
97         our @ISA = qw/DESTROY_MRO_Baseline/;
98     }
99
100     $obj = DESTROY_MRO_Baseline->new();
101     undef $obj;
102     is($x, 1);
103
104     $obj = DESTROY_MRO_Baseline_Child->new();
105     undef $obj;
106     is($x, 2);
107 }
108
109 # Dynamic DESTROY
110 {
111     my $x = 0;
112     my $obj;
113
114     {
115         package DESTROY_MRO_Dynamic;
116         sub new { bless {} => shift }
117
118         package DESTROY_MRO_Dynamic_Child;
119         our @ISA = qw/DESTROY_MRO_Dynamic/;
120     }
121
122     $obj = DESTROY_MRO_Dynamic->new();
123     undef $obj;
124     is($x, 0);
125
126     $obj = DESTROY_MRO_Dynamic_Child->new();
127     undef $obj;
128     is($x, 0);
129
130     no warnings 'once';
131     *DESTROY_MRO_Dynamic::DESTROY = sub { $x++ };
132
133     $obj = DESTROY_MRO_Dynamic->new();
134     undef $obj;
135     is($x, 1);
136
137     $obj = DESTROY_MRO_Dynamic_Child->new();
138     undef $obj;
139     is($x, 2);
140 }
141
142 # clearing @ISA in different ways
143 #  some are destructive to the package, hence the new
144 #  package name each time
145 {
146     no warnings 'uninitialized';
147     {
148         package ISACLEAR;
149         our @ISA = qw/XX YY ZZ/;
150     }
151     # baseline
152     ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX YY ZZ/]));
153
154     # this looks dumb, but it preserves existing behavior for compatibility
155     #  (undefined @ISA elements treated as "main")
156     $ISACLEAR::ISA[1] = undef;
157     ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX main ZZ/]));
158
159     # undef the array itself
160     undef @ISACLEAR::ISA;
161     ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR/]));
162
163     # Now, clear more than one package's @ISA at once
164     {
165         package ISACLEAR1;
166         our @ISA = qw/WW XX/;
167
168         package ISACLEAR2;
169         our @ISA = qw/YY ZZ/;
170     }
171     # baseline
172     ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1 WW XX/]));
173     ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2 YY ZZ/]));
174     (@ISACLEAR1::ISA, @ISACLEAR2::ISA) = ();
175
176     ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1/]));
177     ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2/]));
178
179     # [perl #49564]  This is a pretty obscure way of clearing @ISA but
180     # it tests a regression that affects XS code calling av_clear too.
181     {
182         package ISACLEAR3;
183         our @ISA = qw/WW XX/;
184     }
185     ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3 WW XX/]));
186     {
187         package ISACLEAR3;
188         reset 'I';
189     }
190     ok(eq_array(mro::get_linear_isa('ISACLEAR3'),[qw/ISACLEAR3/]));
191 }
192
193 # Check that recursion bails out "cleanly" in a variety of cases
194 # (as opposed to say, bombing the interpreter or something)
195 {
196     my @recurse_codes = (
197         '@MRO_R1::ISA = "MRO_R2"; @MRO_R2::ISA = "MRO_R1";',
198         '@MRO_R3::ISA = "MRO_R4"; push(@MRO_R4::ISA, "MRO_R3");',
199         '@MRO_R5::ISA = "MRO_R6"; @MRO_R6::ISA = qw/XX MRO_R5 YY/;',
200         '@MRO_R7::ISA = "MRO_R8"; push(@MRO_R8::ISA, qw/XX MRO_R7 YY/)',
201     );
202     foreach my $code (@recurse_codes) {
203         eval $code;
204         ok($@ =~ /Recursive inheritance detected/);
205     }
206 }
207
208 # Check that SUPER caches get invalidated correctly
209 {
210     {
211         package SUPERTEST;
212         sub new { bless {} => shift }
213         sub foo { $_[1]+1 }
214
215         package SUPERTEST::MID;
216         our @ISA = 'SUPERTEST';
217
218         package SUPERTEST::KID;
219         our @ISA = 'SUPERTEST::MID';
220         sub foo { my $s = shift; $s->SUPER::foo(@_) }
221
222         package SUPERTEST::REBASE;
223         sub foo { $_[1]+3 }
224     }
225
226     my $stk_obj = SUPERTEST::KID->new();
227     is($stk_obj->foo(1), 2);
228     { no warnings 'redefine';
229       *SUPERTEST::foo = sub { $_[1]+2 };
230     }
231     is($stk_obj->foo(2), 4);
232     @SUPERTEST::MID::ISA = 'SUPERTEST::REBASE';
233     is($stk_obj->foo(3), 6);
234 }
235
236
237   {
238     # assigning @ISA via arrayref to globref RT 60220
239     package P1;
240     sub new { bless {}, shift }
241     
242     package P2;
243   }
244   *{P2::ISA} = [ 'P1' ];
245   my $foo = P2->new;
246   ok(!eval { $foo->bark }, "no bark method");
247   no warnings 'once';  # otherwise it'll bark about P1::bark used only once
248   *{P1::bark} = sub { "[bark]" };
249   is(scalar eval { $foo->bark }, "[bark]", "can bark now");
250 }
251
252 {
253   # assigning @ISA via arrayref then modifying it RT 72866
254   {
255     package Q1;
256     sub foo {  }
257
258     package Q2;
259     sub bar { }
260
261     package Q3;
262   }
263   push @Q3::ISA, "Q1";
264   can_ok("Q3", "foo");
265   *Q3::ISA = [];
266   push @Q3::ISA, "Q1";
267   can_ok("Q3", "foo");
268   *Q3::ISA = [];
269   push @Q3::ISA, "Q2";
270   can_ok("Q3", "bar");
271   ok(!Q3->can("foo"), "can't call foo method any longer");
272 }
273
274 {
275     # test mro::method_changed_in
276     my $count = mro::get_pkg_gen("MRO_A");
277     mro::method_changed_in("MRO_A");
278     my $count_new = mro::get_pkg_gen("MRO_A");
279
280     is($count_new, $count + 1);
281 }
282
283 {
284     # test if we can call mro::invalidate_all_method_caches;
285     eval {
286         mro::invalidate_all_method_caches();
287     };
288     is($@, "");
289 }
290
291 {
292     # @main::ISA
293     no warnings 'once';
294     @main::ISA = 'parent';
295     my $output = '';
296     *parent::do = sub { $output .= 'parent' };
297     *parent2::do = sub { $output .= 'parent2' };
298     main->do;
299     @main::ISA = 'parent2';
300     main->do;
301     is $output, 'parentparent2', '@main::ISA is magical';
302 }
303
304 {
305     # Undefining *ISA, then modifying @ISA
306     # This broke Class::Trait. See [perl #79024].
307     {package Class::Trait::Base}
308     no strict 'refs';
309     undef   *{"Extra::TSpouse::ISA"};
310     'Extra::TSpouse'->isa('Class::Trait::Base'); # cache the mro
311     unshift @{"Extra::TSpouse::ISA"}, 'Class::Trait::Base';
312     ok 'Extra::TSpouse'->isa('Class::Trait::Base'),
313      'a isa b after undef *a::ISA and @a::ISA modification';
314 }
315
316 {
317     # Deleting $package::{ISA}
318     # Broken in 5.10.0; fixed in 5.13.7
319     @Blength::ISA = 'Bladd';
320     delete $Blength::{ISA};
321     ok !Blength->isa("Bladd"), 'delete $package::{ISA}';
322 }
323
324 {
325     # Undefining stashes
326     @Thrext::ISA = "Thwit";
327     @Thwit::ISA = "Sile";
328     undef %Thwit::;
329     ok !Thrext->isa('Sile'), 'undef %package:: updates subclasses';
330 }
331
332 {
333     # Obliterating @ISA via glob assignment
334     # Broken in 5.14.0; fixed in 5.17.2
335     @Gwythaint::ISA = "Fantastic::Creature";
336     undef *This_glob_haD_better_not_exist; # paranoia; must have no array
337     *Gwythaint::ISA = *This_glob_haD_better_not_exist;
338     ok !Gwythaint->isa("Fantastic::Creature"),
339        'obliterating @ISA via glob assignment';
340 }
341
342 {
343     # Autovivifying @ISA via @{*ISA}
344     undef *fednu::ISA;
345     @{*fednu::ISA} = "pyfg";
346     ok +fednu->isa("pyfg"), 'autovivifying @ISA via *{@ISA}';
347 }