Commit | Line | Data |
e1a479c5 |
1 | #!./perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
d851b122 |
6 | require q(./test.pl); plan(tests => 48); |
e1a479c5 |
7 | |
b2685f0c |
8 | require mro; |
9 | |
e1a479c5 |
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 | |
84dccb35 |
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/; |
e1a479c5 |
27 | is(mro::get_mro('MRO_F'), 'dfs'); |
c94dd5be |
28 | ok(eq_array( |
84dccb35 |
29 | mro::get_linear_isa('MRO_F'), \@MFO_F_DFS |
c94dd5be |
30 | )); |
84dccb35 |
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 | |
e1a479c5 |
37 | mro::set_mro('MRO_F', 'c3'); |
38 | is(mro::get_mro('MRO_F'), 'c3'); |
c94dd5be |
39 | ok(eq_array( |
84dccb35 |
40 | mro::get_linear_isa('MRO_F'), \@MFO_F_C3 |
c94dd5be |
41 | )); |
e1a479c5 |
42 | |
84dccb35 |
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 | |
70cd14a1 |
48 | my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')}; |
c94dd5be |
49 | ok(eq_array( |
50 | \@isarev, |
e1a479c5 |
51 | [qw/MRO_D MRO_E MRO_F/] |
c94dd5be |
52 | )); |
e1a479c5 |
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')); |
70cd14a1 |
61 | |
62 | # is_universal, get_mro, and get_linear_isa should |
63 | # handle non-existant 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); |
9b439311 |
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 | } |
22717f83 |
141 | |
142 | # clearing @ISA in different ways |
5be5c7a6 |
143 | # some are destructive to the package, hence the new |
144 | # package name each time |
22717f83 |
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 | |
5be5c7a6 |
159 | # undef the array itself |
22717f83 |
160 | undef @ISACLEAR::ISA; |
161 | ok(eq_array(mro::get_linear_isa('ISACLEAR'),[qw/ISACLEAR/])); |
915d8d75 |
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 | |
934dcd01 |
176 | ok(eq_array(mro::get_linear_isa('ISACLEAR1'),[qw/ISACLEAR1/])); |
915d8d75 |
177 | ok(eq_array(mro::get_linear_isa('ISACLEAR2'),[qw/ISACLEAR2/])); |
52b45067 |
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/])); |
915d8d75 |
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 | } |
22717f83 |
206 | } |
915d8d75 |
207 | |
2e7640f0 |
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 | |
26d68d86 |
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 | } |
4283ec8b |
251 | |
252 | { |
d851b122 |
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 | { |
4283ec8b |
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 | } |