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