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