t/mro/package_aliases_utf8.t

   1 #!./perl
   2
   3 BEGIN {
   4     $ENV{PERL_UNICODE} = 0;
   5     unless (-d 'blib') {
   6         chdir 't' if -d 't';
   7         @INC = '../lib';
   8     }
   9     require q(./test.pl);
  10 }
  11
  12 use strict;
  13 use warnings;
  14 use utf8;
  15 use open qw( :utf8 :std );
  16
  17 plan(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
  34 ok (ऑlㄉ->isa(Ｎeẁ::), 'ऑlㄉ inherits from Ｎeẁ');
  35 ok (Ｎeẁ->isa(ऑlㄉ::), 'Ｎeẁ inherits from ऑlㄉ');
  36
  37 object_ok (bless ({}, ऑlㄉ::), Ｎeẁ::, 'ऑlㄉ object');
  38 object_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
  43 for(
  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 ) {
  57 my $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; #\
  87 utf8::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).
 105 for(
 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 ɵűʇㄦ::인ንʵ
 169 for(
 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
 258 no 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]
 304 my $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    ~;
 329 utf8::encode($prog);
 330 fresh_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.
 338 no 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â\80\99 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 }
 363 use warnings;
 364
 365 # mro_package_moved needs to check for self-referential packages.
 366 # This broke Text::Template [perl #78362].
 367 watchdog 3;
 368 *ᕘ:: = \%::;
 369 *Aᶜme::Mῌ::Aᶜme:: = \*Aᶜme::; # indirect self-reference
 370 pass("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엞';
 392 undef %ᵍh엞::;
 393 sub F렐ᛔ::ວmᑊ { "clumpren" }
 394 eval '
 395   $ኔƞ::whatever++;
 396   @ኔƞ::ISA = "F렐ᛔ";
 397 ';
 398 is eval { '숩cਲꩋ'->ວmᑊ }, 'clumpren',
 399  'Changes to @ISA after undef via original name';
 400 undef %ᵍh엞::;
 401 eval '
 402   $ᵍh엞::whatever++;
 403   @ᵍh엞::ISA = "F렐ᛔ";
 404 ';
 405 is 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!
 432 bless [], "ᚖგ:"; # autovivify the stash
 433 ok "촐oン"->isa("ᚖგ:"), 'class isa "class:"';
 434 { no strict 'refs'; *{"ᚖგ:::"} = *ᚖგ:: }
 435 ok "촐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 = ':';
 446 bless [], ":";
 447 ok "촐oン"->isa(":"), 'class isa ":"';
 448 { no strict 'refs'; *{":::"} = *ፑňṪu앝ȋ온:: }
 449 ok "촐oン"->isa("ፑňṪu앝ȋ온"),
 450  'isa(ᕘ) when inheriting from ":" which is an alias for ᕘ';
 451 @촐oン::ISA = 'ᚖგ:';
 452 bless [], "ᚖგ:";
 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 = 'ŏ:';
 461 bless [], "ŏ:";
 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