Commit | Line | Data |
---|---|---|
204e6232 BF |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | unless (-d 'blib') { | |
5 | chdir 't' if -d 't'; | |
6 | @INC = '../lib'; | |
7 | } | |
8 | require q(./test.pl); | |
9 | } | |
10 | ||
11 | use strict; | |
12 | use warnings; | |
13 | use utf8; | |
14 | use open qw( :utf8 :std ); | |
15 | ||
16 | plan(tests => 52); | |
17 | ||
18 | { | |
19 | package Neẁ; | |
20 | use strict; | |
21 | use warnings; | |
22 | ||
23 | package ऑlㄉ; | |
24 | use strict; | |
25 | use warnings; | |
26 | ||
27 | { | |
28 | no strict 'refs'; | |
29 | *{'ऑlㄉ::'} = *{'Neẁ::'}; | |
30 | } | |
31 | } | |
32 | ||
33 | ok (ऑlㄉ->isa(Neẁ::), 'ऑlㄉ inherits from Neẁ'); | |
34 | ok (Neẁ->isa(ऑlㄉ::), 'Neẁ inherits from ऑlㄉ'); | |
35 | ||
36 | isa_ok (bless ({}, ऑlㄉ::), Neẁ::, 'ऑlㄉ object'); | |
37 | isa_ok (bless ({}, Neẁ::), ऑlㄉ::, 'Neẁ object'); | |
38 | ||
39 | ||
40 | # Test that replacing a package by assigning to an existing glob | |
41 | # invalidates the isa caches | |
42 | for( | |
43 | { | |
44 | name => 'assigning a glob to a glob', | |
45 | code => '$life_raft = $::{"lㅔf::"}; *lㅔf:: = $::{"릭Ⱶᵀ::"}', | |
46 | }, | |
47 | { | |
48 | name => 'assigning a string to a glob', | |
49 | code => '$life_raft = $::{"lㅔf::"}; *lㅔf:: = "릭Ⱶᵀ::"', | |
50 | }, | |
51 | { | |
52 | name => 'assigning a stashref to a glob', | |
53 | code => '$life_raft = \%lㅔf::; *lㅔf:: = \%릭Ⱶᵀ::', | |
54 | }, | |
55 | ) { | |
56 | my $prog = q~ | |
57 | BEGIN { | |
58 | unless (-d 'blib') { | |
59 | chdir 't' if -d 't'; | |
60 | @INC = '../lib'; | |
61 | } | |
62 | } | |
63 | use utf8; | |
64 | use open qw( :utf8 :std ); | |
65 | ||
66 | @숩cਲꩋ::ISA = "lㅔf"; | |
67 | @lㅔf::ISA = "톺ĺФț"; | |
68 | ||
69 | sub 톺ĺФț::Sᑊeಅḱ { "Woof!" } | |
70 | sub ᴖ릭ᚽʇ::Sᑊeಅḱ { "Bow-wow!" } | |
71 | ||
72 | my $thing = bless [], "숩cਲꩋ"; | |
73 | ||
74 | # mro_package_moved needs to know to skip non-globs | |
75 | $릭Ⱶᵀ::{"ᚷꝆエcƙ::"} = 3; | |
76 | ||
77 | @릭Ⱶᵀ::ISA = 'ᴖ릭ᚽʇ'; | |
78 | my $life_raft; | |
79 | __code__; | |
80 | ||
81 | print $thing->Sᑊeಅḱ, "\n"; | |
82 | ||
83 | undef $life_raft; | |
84 | print $thing->Sᑊeಅḱ, "\n"; | |
85 | ~ =~ s\__code__\$$_{code}\r; #\ | |
86 | utf8::encode($prog); | |
87 | fresh_perl_is | |
88 | $prog, | |
89 | "Bow-wow!\nBow-wow!\n", | |
90 | {}, | |
91 | "replacing packages by $$_{name} updates isa caches"; | |
92 | } | |
93 | ||
94 | # Similar test, but with nested packages | |
95 | # | |
96 | # 톺ĺФț (Woof) ᴖ릭ᚽʇ (Bow-wow) | |
97 | # | | | |
98 | # lㅔf::Side <- 릭Ⱶᵀ::Side | |
99 | # | | |
100 | # 숩cਲꩋ | |
101 | # | |
102 | # This test assigns 릭Ⱶᵀ:: to lㅔf::, indirectly making lㅔf::Side an | |
103 | # alias to 릭Ⱶᵀ::Side (following the arrow in the diagram). | |
104 | for( | |
105 | { | |
106 | name => 'assigning a glob to a glob', | |
107 | code => '$life_raft = $::{"lㅔf::"}; *lㅔf:: = $::{"릭Ⱶᵀ::"}', | |
108 | }, | |
109 | { | |
110 | name => 'assigning a string to a glob', | |
111 | code => '$life_raft = $::{"lㅔf::"}; *lㅔf:: = "릭Ⱶᵀ::"', | |
112 | }, | |
113 | { | |
114 | name => 'assigning a stashref to a glob', | |
115 | code => '$life_raft = \%lㅔf::; *lㅔf:: = \%릭Ⱶᵀ::', | |
116 | }, | |
117 | ) { | |
118 | my $prog = q~ | |
119 | BEGIN { | |
120 | unless (-d 'blib') { | |
121 | chdir 't' if -d 't'; | |
122 | @INC = '../lib'; | |
123 | } | |
124 | } | |
125 | use utf8; | |
126 | use open qw( :utf8 :std ); | |
127 | @숩cਲꩋ::ISA = "lㅔf::Side"; | |
128 | @lㅔf::Side::ISA = "톺ĺФț"; | |
129 | ||
130 | sub 톺ĺФț::Sᑊeಅḱ { "Woof!" } | |
131 | sub ᴖ릭ᚽʇ::Sᑊeಅḱ { "Bow-wow!" } | |
132 | ||
133 | my $thing = bless [], "숩cਲꩋ"; | |
134 | ||
135 | @릭Ⱶᵀ::Side::ISA = 'ᴖ릭ᚽʇ'; | |
136 | my $life_raft; | |
137 | __code__; | |
138 | ||
139 | print $thing->Sᑊeಅḱ, "\n"; | |
140 | ||
141 | undef $life_raft; | |
142 | print $thing->Sᑊeಅḱ, "\n"; | |
143 | ~ =~ s\__code__\$$_{code}\r; | |
144 | utf8::encode($prog); | |
145 | ||
146 | fresh_perl_is | |
147 | $prog, | |
148 | "Bow-wow!\nBow-wow!\n", | |
149 | {}, | |
150 | "replacing nested packages by $$_{name} updates isa caches"; | |
151 | } | |
152 | ||
153 | # Another nested package test, in which the isa cache needs to be reset on | |
154 | # the subclass of a package that does not exist. | |
155 | # | |
156 | # Parenthesized packages do not exist. | |
157 | # | |
158 | # ɵűʇㄦ::인ንʵ ( cฬnए::인ንʵ ) | |
159 | # | | | |
160 | # Lфť R익hȚ | |
161 | # | |
162 | # ɵűʇㄦ -> cฬnए | |
163 | # | |
164 | # This test assigns ɵűʇㄦ:: to cฬnए::, making cฬnए::인ንʵ an alias to | |
165 | # ɵűʇㄦ::인ንʵ. | |
166 | # | |
167 | # Then we also run the test again, but without ɵűʇㄦ::인ንʵ | |
168 | for( | |
169 | { | |
170 | name => 'assigning a glob to a glob', | |
171 | code => '*cฬnए:: = *ɵűʇㄦ::', | |
172 | }, | |
173 | { | |
174 | name => 'assigning a string to a glob', | |
175 | code => '*cฬnए:: = "ɵűʇㄦ::"', | |
176 | }, | |
177 | { | |
178 | name => 'assigning a stashref to a glob', | |
179 | code => '*cฬnए:: = \%ɵűʇㄦ::', | |
180 | }, | |
181 | ) { | |
182 | for my $tail ('인ንʵ', '인ንʵ::', '인ንʵ:::', '인ንʵ::::') { | |
183 | my $prog = q~ | |
184 | BEGIN { | |
185 | unless (-d 'blib') { | |
186 | chdir 't' if -d 't'; | |
187 | @INC = '../lib'; | |
188 | } | |
189 | } | |
190 | use utf8; | |
191 | use open qw( :utf8 :std ); | |
192 | use Encode (); | |
193 | ||
194 | if (grep /\P{ASCII}/, @ARGV) { | |
195 | @ARGV = map { Encode::decode("UTF-8", $_) } @ARGV; | |
196 | } | |
197 | ||
198 | my $tail = shift; | |
199 | @Lфť::ISA = "ɵűʇㄦ::$tail"; | |
200 | @R익hȚ::ISA = "cฬnए::$tail"; | |
201 | bless [], "ɵűʇㄦ::$tail"; # autovivify the stash | |
202 | ||
203 | __code__; | |
204 | ||
205 | print "ok 1", "\n" if Lфť->isa("cฬnए::$tail"); | |
206 | print "ok 2", "\n" if R익hȚ->isa("ɵűʇㄦ::$tail"); | |
207 | print "ok 3", "\n" if R익hȚ->isa("cฬnए::$tail"); | |
208 | print "ok 4", "\n" if Lфť->isa("ɵűʇㄦ::$tail"); | |
209 | ~ =~ s\__code__\$$_{code}\r; | |
210 | utf8::encode($prog); | |
211 | fresh_perl_is | |
212 | $prog, | |
213 | "ok 1\nok 2\nok 3\nok 4\n", | |
214 | { args => [$tail] }, | |
215 | "replacing nonexistent nested packages by $$_{name} updates isa caches" | |
216 | ." ($tail)"; | |
217 | ||
218 | # Same test but with the subpackage autovivified after the assignment | |
219 | $prog = q~ | |
220 | BEGIN { | |
221 | unless (-d 'blib') { | |
222 | chdir 't' if -d 't'; | |
223 | @INC = '../lib'; | |
224 | } | |
225 | } | |
226 | use utf8; | |
227 | use open qw( :utf8 :std ); | |
228 | use Encode (); | |
229 | ||
230 | if (grep /\P{ASCII}/, @ARGV) { | |
231 | @ARGV = map { Encode::decode("UTF-8", $_) } @ARGV; | |
232 | } | |
233 | ||
234 | my $tail = shift; | |
235 | @Lфť::ISA = "ɵűʇㄦ::$tail"; | |
236 | @R익hȚ::ISA = "cฬnए::$tail"; | |
237 | ||
238 | __code__; | |
239 | ||
240 | bless [], "ɵűʇㄦ::$tail"; | |
241 | ||
242 | print "ok 1", "\n" if Lфť->isa("cฬnए::$tail"); | |
243 | print "ok 2", "\n" if R익hȚ->isa("ɵűʇㄦ::$tail"); | |
244 | print "ok 3", "\n" if R익hȚ->isa("cฬnए::$tail"); | |
245 | print "ok 4", "\n" if Lфť->isa("ɵűʇㄦ::$tail"); | |
246 | ~ =~ s\__code__\$$_{code}\r; | |
247 | utf8::encode($prog); | |
248 | fresh_perl_is | |
249 | $prog, | |
250 | "ok 1\nok 2\nok 3\nok 4\n", | |
251 | { args => [$tail] }, | |
252 | "Giving nonexistent packages multiple effective names by $$_{name}" | |
253 | . " ($tail)"; | |
254 | } | |
255 | } | |
256 | ||
257 | no warnings; # temporary; there seems to be a scoping bug, as this does not | |
258 | # work when placed in the blocks below | |
259 | ||
260 | # Test that deleting stash elements containing | |
261 | # subpackages also invalidates the isa cache. | |
262 | # Maybe this does not belong in package_aliases.t, but it is closely | |
263 | # related to the tests immediately preceding. | |
264 | { | |
265 | @ቹऋ::ISA = ("Cuȓ", "ฮンᛞ"); | |
266 | @Cuȓ::ISA = "Hyḹ앛Ҭテ"; | |
267 | ||
268 | sub Hyḹ앛Ҭテ::Sᑊeಅḱ { "Arff!" } | |
269 | sub ฮンᛞ::Sᑊeಅḱ { "Woof!" } | |
270 | ||
271 | my $pet = bless [], "ቹऋ"; | |
272 | ||
273 | my $life_raft = delete $::{'Cuȓ::'}; | |
274 | ||
275 | is $pet->Sᑊeಅḱ, 'Woof!', | |
276 | 'deleting a stash from its parent stash invalidates the isa caches'; | |
277 | ||
278 | undef $life_raft; | |
279 | is $pet->Sᑊeಅḱ, 'Woof!', | |
280 | 'the deleted stash is gone completely when freed'; | |
281 | } | |
282 | # Same thing, but with nested packages | |
283 | { | |
284 | @펱ᑦ::ISA = ("Cuȓȓ::Cuȓȓ::Cuȓȓ", "ɥwn"); | |
285 | @Cuȓȓ::Cuȓȓ::Cuȓȓ::ISA = "lȺt랕ᚖ"; | |
286 | ||
287 | sub lȺt랕ᚖ::Sᑊeಅḱ { "Arff!" } | |
288 | sub ɥwn::Sᑊeಅḱ { "Woof!" } | |
289 | ||
290 | my $pet = bless [], "펱ᑦ"; | |
291 | ||
292 | my $life_raft = delete $::{'Cuȓȓ::'}; | |
293 | ||
294 | is $pet->Sᑊeಅḱ, 'Woof!', | |
295 | 'deleting a stash from its parent stash resets caches of substashes'; | |
296 | ||
297 | undef $life_raft; | |
298 | is $pet->Sᑊeಅḱ, 'Woof!', | |
299 | 'the deleted substash is gone completely when freed'; | |
300 | } | |
301 | ||
302 | # [perl #77358] | |
303 | my $prog = q~#!perl -w | |
304 | BEGIN { | |
305 | unless (-d 'blib') { | |
306 | chdir 't' if -d 't'; | |
307 | @INC = '../lib'; | |
308 | } | |
309 | } | |
310 | use utf8; | |
311 | use open qw( :utf8 :std ); | |
312 | @펱ᑦ::ISA = "T잌ዕ"; | |
313 | @T잌ዕ::ISA = "Bᛆヶṝ"; | |
314 | ||
315 | sub Bᛆヶṝ::Sᑊeಅḱ { print "Woof!\n" } | |
316 | sub lȺt랕ᚖ::Sᑊeಅḱ { print "Bow-wow!\n" } | |
317 | ||
318 | my $pet = bless [], "펱ᑦ"; | |
319 | ||
320 | $pet->Sᑊeಅḱ; | |
321 | ||
322 | sub ດƓ::Sᑊeಅḱ { print "Hello.\n" } # strange ດƓ! | |
323 | @ດƓ::ISA = 'lȺt랕ᚖ'; | |
324 | *T잌ዕ:: = delete $::{'ດƓ::'}; | |
325 | ||
326 | $pet->Sᑊeಅḱ; | |
327 | ~; | |
328 | utf8::encode($prog); | |
329 | fresh_perl_is | |
330 | $prog, | |
331 | "Woof!\nHello.\n", | |
332 | { stderr => 1 }, | |
333 | "Assigning a nameless package over one w/subclasses updates isa caches"; | |
334 | ||
335 | # mro_package_moved needs to make a distinction between replaced and | |
336 | # assigned stashes when keeping track of what it has seen so far. | |
337 | no warnings; { | |
338 | no strict 'refs'; | |
339 | ||
340 | sub ʉ::bᓗnǩ::bᓗnǩ::ພo { "bbb" } | |
341 | sub ᵛeↄl움::ພo { "lasrevinu" } | |
342 | @ݏ엗Ƚeᵬૐᵖ::ISA = qw 'ພo::bᓗnǩ::bᓗnǩ ᵛeↄl움'; | |
343 | *ພo::ବㄗ:: = *ʉ::bᓗnǩ::; # now ʉ::bᓗnǩ:: is on both sides | |
344 | *ພo:: = *ʉ::; # here ʉ::bᓗnǩ:: is both deleted and added | |
345 | *ʉ:: = *ቦᵕ::; # now it is only known as ພo::bᓗnǩ:: | |
346 | ||
347 | # At this point, before the bug was fixed, %ພo::bᓗnǩ::bᓗnǩ:: ended | |
348 | # up with no effective name, allowing it to be deleted without updating | |
349 | # its subclassesâ\80\99 caches. | |
350 | ||
351 | my $accum = ''; | |
352 | ||
353 | $accum .= 'ݏ엗Ƚeᵬૐᵖ'->ພo; # bbb | |
354 | delete ${"ພo::bᓗnǩ::"}{"bᓗnǩ::"}; | |
355 | $accum .= 'ݏ엗Ƚeᵬૐᵖ'->ພo; # bbb (Oops!) | |
356 | @ݏ엗Ƚeᵬૐᵖ::ISA = @ݏ엗Ƚeᵬૐᵖ::ISA; | |
357 | $accum .= 'ݏ엗Ƚeᵬૐᵖ'->ພo; # lasrevinu | |
358 | ||
359 | is $accum, 'bbblasrevinulasrevinu', | |
360 | 'nested classes deleted & added simultaneously'; | |
361 | } | |
362 | use warnings; | |
363 | ||
364 | # mro_package_moved needs to check for self-referential packages. | |
365 | # This broke Text::Template [perl #78362]. | |
366 | watchdog 3; | |
367 | *ᕘ:: = \%::; | |
368 | *Aᶜme::Mῌ::Aᶜme:: = \*Aᶜme::; # indirect self-reference | |
369 | pass("mro_package_moved and self-referential packages"); | |
370 | ||
371 | # Deleting a glob whose name does not indicate its location in the symbol | |
372 | # table but which nonetheless *is* in the symbol table. | |
373 | { | |
374 | no strict refs=>; | |
375 | no warnings; | |
376 | @ოƐ::mഒrェ::ISA = "foᚒ"; | |
377 | sub foᚒ::ວmᑊ { "aoeaa" } | |
378 | *ťວ:: = *ოƐ::; | |
379 | delete $::{"ოƐ::"}; | |
380 | @C힐dᒡl았::ISA = 'ťວ::mഒrェ'; | |
381 | my $accum = 'C힐dᒡl았'->ວmᑊ . '-'; | |
382 | my $life_raft = delete ${"ťວ::"}{"mഒrェ::"}; | |
383 | $accum .= eval { 'C힐dᒡl았'->ວmᑊ } // '<undef>'; | |
384 | is $accum, 'aoeaa-<undef>', | |
385 | 'Deleting globs whose loc in the symtab differs from gv_fullname' | |
386 | } | |
387 | ||
388 | # Pathological test for undeffing a stash that has an alias. | |
389 | *ᵍh엞:: = *ኔƞ::; | |
390 | @숩cਲꩋ::ISA = 'ᵍh엞'; | |
391 | undef %ᵍh엞::; | |
392 | sub F렐ᛔ::ວmᑊ { "clumpren" } | |
393 | eval ' | |
394 | $ኔƞ::whatever++; | |
395 | @ኔƞ::ISA = "F렐ᛔ"; | |
396 | '; | |
397 | is eval { '숩cਲꩋ'->ວmᑊ }, 'clumpren', | |
398 | 'Changes to @ISA after undef via original name'; | |
399 | undef %ᵍh엞::; | |
400 | eval ' | |
401 | $ᵍh엞::whatever++; | |
402 | @ᵍh엞::ISA = "F렐ᛔ"; | |
403 | '; | |
404 | is eval { '숩cਲꩋ'->ວmᑊ }, 'clumpren', | |
405 | 'Changes to @ISA after undef via alias'; | |
406 | ||
407 | ||
408 | # Packages whose containing stashes have aliases must lose all names cor- | |
409 | # responding to that container when detached. | |
410 | { | |
411 | {package śmᛅḙ::በɀ} # autovivify | |
412 | *pḢ린ᚷ:: = *śmᛅḙ::; # śmᛅḙ::በɀ now also named pḢ린ᚷ::በɀ | |
413 | *본:: = delete $śmᛅḙ::{"በɀ::"}; | |
414 | # In 5.13.7, it has now lost its śmᛅḙ::በɀ name (reverting to pḢ린ᚷ::በɀ | |
415 | # as the effective name), and gained 본 as an alias. | |
416 | # In 5.13.8, both śmᛅḙ::በɀ *and* pḢ린ᚷ::በɀ names are deleted. | |
417 | ||
418 | # Make some methods | |
419 | no strict 'refs'; | |
420 | *{"pḢ린ᚷ::በɀ::fฤmᛈ"} = sub { "hello" }; | |
421 | sub Fルmፕṟ::fฤmᛈ { "good bye" }; | |
422 | ||
423 | @ᵇるᣘ킨::ISA = qw "본 Fルmፕṟ"; # now wrongly inherits from pḢ린ᚷ::በɀ | |
424 | ||
425 | is fฤmᛈ ᵇるᣘ킨, "good bye", | |
426 | 'detached stashes lose all names corresponding to the containing stash'; | |
427 | } | |
428 | ||
429 | # Crazy edge cases involving packages ending with a single : | |
430 | @촐oン::ISA = 'ᚖგ:'; # pun intended! | |
431 | bless [], "ᚖგ:"; # autovivify the stash | |
432 | ok "촐oン"->isa("ᚖგ:"), 'class isa "class:"'; | |
433 | { no strict 'refs'; *{"ᚖგ:::"} = *ᚖგ:: } | |
434 | ok "촐oン"->isa("ᚖგ"), | |
435 | 'isa(ᕘ) when inheriting from "class:" which is an alias for ᕘ'; | |
436 | { | |
437 | no warnings; | |
438 | # The next line of code is *not* normative. If the structure changes, | |
439 | # this line needs to change, too. | |
440 | my $ᕘ = delete $ᚖგ::{":"}; | |
441 | ok !촐oン->isa("ᚖგ"), | |
442 | 'class that isa "class:" no longer isa ᕘ if "class:" has been deleted'; | |
443 | } | |
444 | @촐oン::ISA = ':'; | |
445 | bless [], ":"; | |
446 | ok "촐oン"->isa(":"), 'class isa ":"'; | |
447 | { no strict 'refs'; *{":::"} = *ፑňṪu앝ȋ온:: } | |
448 | ok "촐oン"->isa("ፑňṪu앝ȋ온"), | |
449 | 'isa(ᕘ) when inheriting from ":" which is an alias for ᕘ'; | |
450 | @촐oン::ISA = 'ᚖგ:'; | |
451 | bless [], "ᚖგ:"; | |
452 | { | |
453 | no strict 'refs'; | |
454 | my $life_raft = \%{"ᚖგ:::"}; | |
455 | *{"ᚖგ:::"} = \%ᚖგ::; | |
456 | ok "촐oン"->isa("ᚖგ"), | |
457 | 'isa(ᕘ) when inheriting from "class:" after hash-to-glob assignment'; | |
458 | } | |
459 | @촐oン::ISA = 'ŏ:'; | |
460 | bless [], "ŏ:"; | |
461 | { | |
462 | no strict 'refs'; | |
463 | my $life_raft = \%{"ŏ:::"}; | |
464 | *{"ŏ:::"} = "ᚖგ::"; | |
465 | ok "촐oン"->isa("ᚖგ"), | |
466 | 'isa(ᕘ) when inheriting from "class:" after string-to-glob assignment'; | |
467 | } | |
468 | =cut |