This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [perl #46217] (resent) Typeglobs vs. SUPER:: (Hook::LexWrap failure)
[perl5.git] / t / mro / basic.t
CommitLineData
e1a479c5
BB
1#!./perl
2
3use strict;
4use warnings;
5
2e7640f0 6require q(./test.pl); plan(tests => 38);
e1a479c5
BB
7
8{
9 package MRO_A;
10 our @ISA = qw//;
11 package MRO_B;
12 our @ISA = qw//;
13 package MRO_C;
14 our @ISA = qw//;
15 package MRO_D;
16 our @ISA = qw/MRO_A MRO_B MRO_C/;
17 package MRO_E;
18 our @ISA = qw/MRO_A MRO_B MRO_C/;
19 package MRO_F;
20 our @ISA = qw/MRO_D MRO_E/;
21}
22
84dccb35
NC
23my @MFO_F_DFS = qw/MRO_F MRO_D MRO_A MRO_B MRO_C MRO_E/;
24my @MFO_F_C3 = qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/;
e1a479c5 25is(mro::get_mro('MRO_F'), 'dfs');
c94dd5be 26ok(eq_array(
84dccb35 27 mro::get_linear_isa('MRO_F'), \@MFO_F_DFS
c94dd5be 28));
84dccb35
NC
29
30ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS));
31ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3));
32eval{mro::get_linear_isa('MRO_F', 'C3')};
33like($@, qr/^Invalid mro name: 'C3'/);
34
e1a479c5
BB
35mro::set_mro('MRO_F', 'c3');
36is(mro::get_mro('MRO_F'), 'c3');
c94dd5be 37ok(eq_array(
84dccb35 38 mro::get_linear_isa('MRO_F'), \@MFO_F_C3
c94dd5be 39));
e1a479c5 40
84dccb35
NC
41ok(eq_array(mro::get_linear_isa('MRO_F', 'dfs'), \@MFO_F_DFS));
42ok(eq_array(mro::get_linear_isa('MRO_F', 'c3'), \@MFO_F_C3));
43eval{mro::get_linear_isa('MRO_F', 'C3')};
44like($@, qr/^Invalid mro name: 'C3'/);
45
70cd14a1 46my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')};
c94dd5be
RGS
47ok(eq_array(
48 \@isarev,
e1a479c5 49 [qw/MRO_D MRO_E MRO_F/]
c94dd5be 50));
e1a479c5
BB
51
52ok(!mro::is_universal('MRO_B'));
53
54@UNIVERSAL::ISA = qw/MRO_F/;
55ok(mro::is_universal('MRO_B'));
56
57@UNIVERSAL::ISA = ();
58ok(mro::is_universal('MRO_B'));
70cd14a1
CB
59
60# is_universal, get_mro, and get_linear_isa should
61# handle non-existant packages sanely
62ok(!mro::is_universal('Does_Not_Exist'));
63is(mro::get_mro('Also_Does_Not_Exist'), 'dfs');
64ok(eq_array(
65 mro::get_linear_isa('Does_Not_Exist_Three'),
66 [qw/Does_Not_Exist_Three/]
67));
68
69# Assigning @ISA via globref
70{
71 package MRO_TestBase;
72 sub testfunc { return 123 }
73 package MRO_TestOtherBase;
74 sub testfunctwo { return 321 }
75 package MRO_M; our @ISA = qw/MRO_TestBase/;
76}
77*MRO_N::ISA = *MRO_M::ISA;
78is(eval { MRO_N->testfunc() }, 123);
79
80# XXX TODO (when there's a way to backtrack through a glob's aliases)
81# push(@MRO_M::ISA, 'MRO_TestOtherBase');
82# is(eval { MRO_N->testfunctwo() }, 321);
9b439311
BB
83
84# Simple DESTROY Baseline
85{
86 my $x = 0;
87 my $obj;
88
89 {
90 package DESTROY_MRO_Baseline;
91 sub new { bless {} => shift }
92 sub DESTROY { $x++ }
93
94 package DESTROY_MRO_Baseline_Child;
95 our @ISA = qw/DESTROY_MRO_Baseline/;
96 }
97
98 $obj = DESTROY_MRO_Baseline->new();
99 undef $obj;
100 is($x, 1);
101
102 $obj = DESTROY_MRO_Baseline_Child->new();
103 undef $obj;
104 is($x, 2);
105}
106
107# Dynamic DESTROY
108{
109 my $x = 0;
110 my $obj;
111
112 {
113 package DESTROY_MRO_Dynamic;
114 sub new { bless {} => shift }
115
116 package DESTROY_MRO_Dynamic_Child;
117 our @ISA = qw/DESTROY_MRO_Dynamic/;
118 }
119
120 $obj = DESTROY_MRO_Dynamic->new();
121 undef $obj;
122 is($x, 0);
123
124 $obj = DESTROY_MRO_Dynamic_Child->new();
125 undef $obj;
126 is($x, 0);
127
128 no warnings 'once';
129 *DESTROY_MRO_Dynamic::DESTROY = sub { $x++ };
130
131 $obj = DESTROY_MRO_Dynamic->new();
132 undef $obj;
133 is($x, 1);
134
135 $obj = DESTROY_MRO_Dynamic_Child->new();
136 undef $obj;
137 is($x, 2);
138}
22717f83
BB
139
140# clearing @ISA in different ways
5be5c7a6
BB
141# some are destructive to the package, hence the new
142# package name each time
22717f83
BB
143{
144 no warnings 'uninitialized';
145 {
146 package ISACLEAR;
147 our @ISA = qw/XX YY ZZ/;
148 }
149 # baseline
150 ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX YY ZZ/]));
151
152 # this looks dumb, but it preserves existing behavior for compatibility
153 # (undefined @ISA elements treated as "main")
154 $ISACLEAR::ISA[1] = undef;
155 ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR XX main ZZ/]));
156
5be5c7a6 157 # undef the array itself
22717f83
BB
158 undef @ISACLEAR::ISA;
159 ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR/]));
915d8d75
RD
160
161 # Now, clear more than one package's @ISA at once
162 {
163 package ISACLEAR1;
164 our @ISA = qw/WW XX/;
165
166 package ISACLEAR2;
167 our @ISA = qw/YY ZZ/;
168 }
169 # baseline
170 ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1 WW XX/]));
171 ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2 YY ZZ/]));
172 (@ISACLEAR1::ISA, @ISACLEAR2::ISA) = ();
173
934dcd01 174 ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1/]));
915d8d75
RD
175 ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2/]));
176}
177
178# Check that recursion bails out "cleanly" in a variety of cases
179# (as opposed to say, bombing the interpreter or something)
180{
181 my @recurse_codes = (
182 '@MRO_R1::ISA = "MRO_R2"; @MRO_R2::ISA = "MRO_R1";',
183 '@MRO_R3::ISA = "MRO_R4"; push(@MRO_R4::ISA, "MRO_R3");',
184 '@MRO_R5::ISA = "MRO_R6"; @MRO_R6::ISA = qw/XX MRO_R5 YY/;',
185 '@MRO_R7::ISA = "MRO_R8"; push(@MRO_R8::ISA, qw/XX MRO_R7 YY/)',
186 );
187 foreach my $code (@recurse_codes) {
188 eval $code;
189 ok($@ =~ /Recursive inheritance detected/);
190 }
22717f83 191}
915d8d75 192
2e7640f0
BB
193# Check that SUPER caches get invalidated correctly
194{
195 {
196 package SUPERTEST;
197 sub new { bless {} => shift }
198 sub foo { $_[1]+1 }
199
200 package SUPERTEST::MID;
201 our @ISA = 'SUPERTEST';
202
203 package SUPERTEST::KID;
204 our @ISA = 'SUPERTEST::MID';
205 sub foo { my $s = shift; $s->SUPER::foo(@_) }
206
207 package SUPERTEST::REBASE;
208 sub foo { $_[1]+3 }
209 }
210
211 my $stk_obj = SUPERTEST::KID->new();
212 is($stk_obj->foo(1), 2);
213 { no warnings 'redefine';
214 *SUPERTEST::foo = sub { $_[1]+2 };
215 }
216 is($stk_obj->foo(2), 4);
217 @SUPERTEST::MID::ISA = 'SUPERTEST::REBASE';
218 is($stk_obj->foo(3), 6);
219}
220