Commit | Line | Data |
---|---|---|
204e6232 BF |
1 | #!./perl |
2 | ||
3 | use utf8; | |
4 | use open qw( :utf8 :std ); | |
5 | use strict; | |
6 | use warnings; | |
7 | ||
8 | BEGIN { require q(./test.pl); } plan(tests => 53); | |
9 | ||
10 | require mro; | |
11 | ||
12 | { | |
13 | package MRO_அ; | |
14 | our @ISA = qw//; | |
15 | package MRO_ɓ; | |
16 | our @ISA = qw//; | |
17 | package MRO_ᶝ; | |
18 | our @ISA = qw//; | |
19 | package MRO_d; | |
20 | our @ISA = qw/MRO_அ MRO_ɓ MRO_ᶝ/; | |
21 | package MRO_ɛ; | |
22 | our @ISA = qw/MRO_அ MRO_ɓ MRO_ᶝ/; | |
23 | package MRO_ᚠ; | |
24 | our @ISA = qw/MRO_d MRO_ɛ/; | |
25 | } | |
26 | ||
27 | my @MFO_ᚠ_DFS = qw/MRO_ᚠ MRO_d MRO_அ MRO_ɓ MRO_ᶝ MRO_ɛ/; | |
28 | my @MFO_ᚠ_C3 = qw/MRO_ᚠ MRO_d MRO_ɛ MRO_அ MRO_ɓ MRO_ᶝ/; | |
29 | is(mro::get_mro('MRO_ᚠ'), 'dfs'); | |
30 | ok(eq_array( | |
31 | mro::get_linear_isa('MRO_ᚠ'), \@MFO_ᚠ_DFS | |
32 | )); | |
33 | ||
34 | ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'dfs'), \@MFO_ᚠ_DFS)); | |
35 | ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'c3'), \@MFO_ᚠ_C3)); | |
36 | eval{mro::get_linear_isa('MRO_ᚠ', 'C3')}; | |
37 | like($@, qr/^Invalid mro name: 'C3'/); | |
38 | ||
39 | mro::set_mro('MRO_ᚠ', 'c3'); | |
40 | is(mro::get_mro('MRO_ᚠ'), 'c3'); | |
41 | ok(eq_array( | |
42 | mro::get_linear_isa('MRO_ᚠ'), \@MFO_ᚠ_C3 | |
43 | )); | |
44 | ||
45 | ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'dfs'), \@MFO_ᚠ_DFS)); | |
46 | ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'c3'), \@MFO_ᚠ_C3)); | |
47 | eval{mro::get_linear_isa('MRO_ᚠ', 'C3')}; | |
48 | like($@, qr/^Invalid mro name: 'C3'/); | |
49 | ||
50 | ok(!mro::is_universal('MRO_ɓ')); | |
51 | ||
52 | @UNIVERSAL::ISA = qw/MRO_ᚠ/; | |
53 | ok(mro::is_universal('MRO_ɓ')); | |
54 | ||
55 | @UNIVERSAL::ISA = (); | |
56 | ok(!mro::is_universal('MRO_ᚠ')); | |
57 | ok(!mro::is_universal('MRO_ɓ')); | |
58 | ||
59 | # is_universal, get_mro, and get_linear_isa should | |
60 | # handle non-existent packages sanely | |
61 | ok(!mro::is_universal('Does_Not_Exist')); | |
62 | is(mro::get_mro('Also_Does_Not_Exist'), 'dfs'); | |
63 | ok(eq_array( | |
64 | mro::get_linear_isa('Does_Not_Exist_Three'), | |
65 | [qw/Does_Not_Exist_Three/] | |
66 | )); | |
67 | ||
68 | # Assigning @ISA via globref | |
69 | { | |
70 | package MRO_ҭṣṱबꗻ; | |
71 | sub 텟tf운ꜿ { return 123 } | |
72 | package MRO_Test옽ḦРꤷsӭ; | |
73 | sub 텟ₜꖢᶯcƧ { return 321 } | |
74 | package MRO_Ɯ; our @ISA = qw/MRO_ҭṣṱबꗻ/; | |
75 | } | |
76 | *MRO_ᕡ::ISA = *MRO_Ɯ::ISA; | |
77 | is(eval { MRO_ᕡ->텟tf운ꜿ() }, 123); | |
78 | ||
79 | # XXX TODO (when there's a way to backtrack through a glob's aliases) | |
80 | # push(@MRO_M::ISA, 'MRO_TestOtherBase'); | |
81 | # is(eval { MRO_N->testfunctwo() }, 321); | |
82 | ||
83 | # Simple DESTROY Baseline | |
84 | { | |
85 | my $x = 0; | |
86 | my $obj; | |
87 | ||
88 | { | |
89 | package DESTROY_MRO_Bӓeᓕne; | |
90 | sub new { bless {} => shift } | |
91 | sub DESTROY { $x++ } | |
92 | ||
93 | package DESTROY_MRO_Bӓeᓕne_χḻɖ; | |
94 | our @ISA = qw/DESTROY_MRO_Bӓeᓕne/; | |
95 | } | |
96 | ||
97 | $obj = DESTROY_MRO_Bӓeᓕne->new(); | |
98 | undef $obj; | |
99 | is($x, 1); | |
100 | ||
101 | $obj = DESTROY_MRO_Bӓeᓕne_χḻɖ->new(); | |
102 | undef $obj; | |
103 | is($x, 2); | |
104 | } | |
105 | ||
106 | # Dynamic DESTROY | |
107 | { | |
108 | my $x = 0; | |
109 | my $obj; | |
110 | ||
111 | { | |
112 | package DESTROY_MRO_Dჷ및; | |
113 | sub new { bless {} => shift } | |
114 | ||
115 | package DESTROY_MRO_Dჷ및_χḻɖ; | |
116 | our @ISA = qw/DESTROY_MRO_Dჷ및/; | |
117 | } | |
118 | ||
119 | $obj = DESTROY_MRO_Dჷ및->new(); | |
120 | undef $obj; | |
121 | is($x, 0); | |
122 | ||
123 | $obj = DESTROY_MRO_Dჷ및_χḻɖ->new(); | |
124 | undef $obj; | |
125 | is($x, 0); | |
126 | ||
127 | no warnings 'once'; | |
128 | *DESTROY_MRO_Dჷ및::DESTROY = sub { $x++ }; | |
129 | ||
130 | $obj = DESTROY_MRO_Dჷ및->new(); | |
131 | undef $obj; | |
132 | is($x, 1); | |
133 | ||
134 | $obj = DESTROY_MRO_Dჷ및_χḻɖ->new(); | |
135 | undef $obj; | |
136 | is($x, 2); | |
137 | } | |
138 | ||
139 | # clearing @ISA in different ways | |
140 | # some are destructive to the package, hence the new | |
141 | # package name each time | |
142 | { | |
143 | no warnings 'uninitialized'; | |
144 | { | |
145 | package ᛁ앛ଌᛠ; | |
146 | our @ISA = qw/xx ƳƳ ƶƶ/; | |
147 | } | |
148 | # baseline | |
149 | ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ'),[qw/ᛁ앛ଌᛠ xx ƳƳ ƶƶ/])); | |
150 | ||
151 | # this looks dumb, but it preserves existing behavior for compatibility | |
152 | # (undefined @ISA elements treated as "main") | |
153 | $ᛁ앛ଌᛠ::ISA[1] = undef; | |
154 | ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ'),[qw/ᛁ앛ଌᛠ xx main ƶƶ/])); | |
155 | ||
156 | # undef the array itself | |
157 | undef @ᛁ앛ଌᛠ::ISA; | |
158 | ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ'),[qw/ᛁ앛ଌᛠ/])); | |
159 | ||
160 | # Now, clear more than one package's @ISA at once | |
161 | { | |
162 | package ᛁ앛ଌᛠ1; | |
163 | our @ISA = qw/WẆ xx/; | |
164 | ||
165 | package ᛁ앛ଌᛠ2; | |
166 | our @ISA = qw/ƳƳ ƶƶ/; | |
167 | } | |
168 | # baseline | |
169 | ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ1'),[qw/ᛁ앛ଌᛠ1 WẆ xx/])); | |
170 | ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ2'),[qw/ᛁ앛ଌᛠ2 ƳƳ ƶƶ/])); | |
171 | (@ᛁ앛ଌᛠ1::ISA, @ᛁ앛ଌᛠ2::ISA) = (); | |
172 | ||
173 | ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ1'),[qw/ᛁ앛ଌᛠ1/])); | |
174 | ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ2'),[qw/ᛁ앛ଌᛠ2/])); | |
175 | ||
176 | # [perl #49564] This is a pretty obscure way of clearing @ISA but | |
177 | # it tests a regression that affects XS code calling av_clear too. | |
178 | { | |
179 | package ᛁ앛ଌᛠ3; | |
180 | our @ISA = qw/WẆ xx/; | |
181 | } | |
182 | ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ3'),[qw/ᛁ앛ଌᛠ3 WẆ xx/])); | |
183 | { | |
184 | package ᛁ앛ଌᛠ3; | |
185 | reset 'I'; | |
186 | } | |
187 | ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ3'),[qw/ᛁ앛ଌᛠ3/])); | |
188 | } | |
189 | ||
190 | # Check that recursion bails out "cleanly" in a variety of cases | |
191 | # (as opposed to say, bombing the interpreter or something) | |
192 | { | |
193 | my @recurse_codes = ( | |
194 | '@MRO_ഋ1::ISA = "MRO_ഋ2"; @MRO_ഋ2::ISA = "MRO_ഋ1";', | |
195 | '@MRO_ഋ3::ISA = "MRO_ഋ4"; push(@MRO_ഋ4::ISA, "MRO_ഋ3");', | |
196 | '@MRO_ഋ5::ISA = "MRO_ഋ6"; @MRO_ഋ6::ISA = qw/xx MRO_ഋ5 ƳƳ/;', | |
197 | '@MRO_ഋ7::ISA = "MRO_ഋ8"; push(@MRO_ഋ8::ISA, qw/xx MRO_ഋ7 ƳƳ/)', | |
198 | ); | |
199 | foreach my $code (@recurse_codes) { | |
200 | eval $code; | |
201 | ok($@ =~ /Recursive inheritance detected/); | |
202 | } | |
203 | } | |
204 | ||
205 | # Check that SUPER caches get invalidated correctly | |
206 | { | |
207 | { | |
208 | package スṔઍR텟ʇ; | |
209 | sub new { bless {} => shift } | |
210 | sub ຟઓ { $_[1]+1 } | |
211 | ||
212 | package スṔઍR텟ʇ::MᶤƉ; | |
213 | our @ISA = 'スṔઍR텟ʇ'; | |
214 | ||
215 | package スṔઍR텟ʇ::킫; | |
216 | our @ISA = 'スṔઍR텟ʇ::MᶤƉ'; | |
217 | sub ຟઓ { my $s = shift; $s->SUPER::ຟઓ(@_) } | |
218 | ||
219 | package スṔઍR텟ʇ::렙ﷰए; | |
220 | sub ຟઓ { $_[1]+3 } | |
221 | } | |
222 | ||
223 | my $stk_obj = スṔઍR텟ʇ::킫->new(); | |
224 | is($stk_obj->ຟઓ(1), 2); | |
225 | { no warnings 'redefine'; | |
226 | *スṔઍR텟ʇ::ຟઓ = sub { $_[1]+2 }; | |
227 | } | |
228 | is($stk_obj->ຟઓ(2), 4); | |
229 | @スṔઍR텟ʇ::MᶤƉ::ISA = 'スṔઍR텟ʇ::렙ﷰए'; | |
230 | is($stk_obj->ຟઓ(3), 6); | |
231 | } | |
232 | ||
233 | { | |
234 | { | |
235 | # assigning @ISA via arrayref to globref RT 60220 | |
236 | package ᛔ1; | |
237 | sub new { bless {}, shift } | |
238 | ||
239 | package ᛔ2; | |
240 | } | |
241 | *{ᛔ2::ISA} = [ 'ᛔ1' ]; | |
242 | my $foo = ᛔ2->new; | |
243 | ok(!eval { $foo->ɓᛅƘ }, "no ɓᛅƘ method"); | |
244 | no warnings 'once'; # otherwise it'll bark about ᛔ1::ɓᛅƘ used only once | |
245 | *{ᛔ1::ɓᛅƘ} = sub { "[ɓᛅƘ]" }; | |
246 | is(scalar eval { $foo->ɓᛅƘ }, "[ɓᛅƘ]", "can ɓᛅƘ now"); | |
247 | is $@, ''; | |
248 | } | |
249 | ||
250 | { | |
251 | # assigning @ISA via arrayref then modifying it RT 72866 | |
252 | { | |
253 | package ㄑ1; | |
254 | sub Fஓ { } | |
255 | ||
256 | package ㄑ2; | |
257 | sub ƚ { } | |
258 | ||
259 | package ㄑ3; | |
260 | } | |
261 | push @ㄑ3::ISA, "ㄑ1"; | |
262 | can_ok("ㄑ3", "Fஓ"); | |
263 | *ㄑ3::ISA = []; | |
264 | push @ㄑ3::ISA, "ㄑ1"; | |
265 | can_ok("ㄑ3", "Fஓ"); | |
266 | *ㄑ3::ISA = []; | |
267 | push @ㄑ3::ISA, "ㄑ2"; | |
268 | can_ok("ㄑ3", "ƚ"); | |
269 | ok(!ㄑ3->can("Fஓ"), "can't call Fஓ method any longer"); | |
270 | } | |
271 | ||
272 | { | |
273 | # test mro::method_changed_in | |
274 | my $count = mro::get_pkg_gen("MRO_அ"); | |
275 | mro::method_changed_in("MRO_அ"); | |
276 | my $count_new = mro::get_pkg_gen("MRO_அ"); | |
277 | ||
278 | is($count_new, $count + 1); | |
279 | } | |
280 | ||
281 | { | |
282 | # test if we can call mro::invalidate_all_method_caches; | |
283 | eval { | |
284 | mro::invalidate_all_method_caches(); | |
285 | }; | |
286 | is($@, ""); | |
287 | } | |
288 | ||
289 | { | |
290 | # @main::ISA | |
291 | no warnings 'once'; | |
292 | @main::ISA = 'პᛅeȵᛏ'; | |
293 | my $output = ''; | |
294 | *პᛅeȵᛏ::ど = sub { $output .= 'პᛅeȵᛏ' }; | |
295 | *პᛅeȵᛏ2::ど = sub { $output .= 'პᛅeȵᛏ2' }; | |
296 | main->ど; | |
297 | @main::ISA = 'პᛅeȵᛏ2'; | |
298 | main->ど; | |
299 | is $output, 'პᛅeȵᛏპᛅeȵᛏ2', '@main::ISA is magical'; | |
300 | } | |
301 | ||
302 | { | |
303 | # Undefining *ISA, then modifying @ISA | |
304 | # This broke Class::Trait. See [perl #79024]. | |
305 | {package Class::Trait::Base} | |
306 | no strict 'refs'; | |
307 | undef *{"एxṰர::ʦፖㄡsȨ::ISA"}; | |
308 | 'एxṰர::ʦፖㄡsȨ'->isa('Class::Trait::Base'); # cache the mro | |
309 | unshift @{"एxṰர::ʦፖㄡsȨ::ISA"}, 'Class::Trait::Base'; | |
310 | ok 'एxṰர::ʦፖㄡsȨ'->isa('Class::Trait::Base'), | |
311 | 'a isa b after undef *a::ISA and @a::ISA modification'; | |
312 | } | |
313 | ||
314 | { | |
315 | # Deleting $package::{ISA} | |
316 | # Broken in 5.10.0; fixed in 5.13.7 | |
317 | @BḼᵑth::ISA = 'Bલdḏ'; | |
318 | delete $BḼᵑth::{ISA}; | |
319 | ok !BḼᵑth->isa("Bલdḏ"), 'delete $package::{ISA}'; | |
320 | } | |
321 | ||
322 | { | |
323 | # Undefining stashes | |
324 | @ᖫᕃㄒṭ::ISA = "ᖮw잍"; | |
325 | @ᖮw잍::ISA = "ሲঌએ"; | |
326 | undef %ᖮw잍::; | |
327 | ok !ᖫᕃㄒṭ->isa('ሲঌએ'), 'undef %package:: updates subclasses'; | |
328 | } |