mro UTF8 cleanup.

This patch also duplicates existing mro tests with copies that use
Unicode in identifiers, to test the mro code.

Since those tests trigger it, it also fixes a bug in the parsing
of *{...}: If the first character inside the braces is a non-ASCII
Unicode identifier character, the inside is now implicitly quoted
if it is just an identifier (just as it is with ASCII identifiers),
instead of being parsed as a bareword that would violate strict subs.

1 files changed, 468 insertions, 0 deletions

diff --git a/t/mro/package_aliases_utf8.t b/t/mro/package_aliases_utf8.t
new file mode 100644
index 0000000000..ae214e5ce5
--- /dev/null
+++ b/t/mro/package_aliases_utf8.t
@@ -0,0 +1,468 @@
+#!./perl
+
+BEGIN {
+    unless (-d 'blib') {
+        chdir 't' if -d 't';
+        @INC = '../lib';
+    }
+    require q(./test.pl);
+}
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+plan(tests => 52);
+
+{
+    package Ｎeẁ;
+    use strict;
+    use warnings;
+
+    package ऑlㄉ;
+    use strict;
+    use warnings;
+
+    {
+      no strict 'refs';
+      *{'ऑlㄉ::'} = *{'Ｎeẁ::'};
+    }
+}
+
+ok (ऑlㄉ->isa(Ｎeẁ::), 'ऑlㄉ inherits from Ｎeẁ');
+ok (Ｎeẁ->isa(ऑlㄉ::), 'Ｎeẁ inherits from ऑlㄉ');
+
+isa_ok (bless ({}, ऑlㄉ::), Ｎeẁ::, 'ऑlㄉ object');
+isa_ok (bless ({}, Ｎeẁ::), ऑlㄉ::, 'Ｎeẁ object');
+
+
+# Test that replacing a package by assigning to an existing glob
+# invalidates the isa caches
+for(
+ {
+   name => 'assigning a glob to a glob',
+   code => '$life_raft = $::{"ｌㅔf::"}; *ｌㅔf:: = $::{"릭Ⱶᵀ::"}',
+ },
+ {
+   name => 'assigning a string to a glob',
+   code => '$life_raft = $::{"ｌㅔf::"}; *ｌㅔf:: = "릭Ⱶᵀ::"',
+ },
+ {
+   name => 'assigning a stashref to a glob',
+   code => '$life_raft = \%ｌㅔf::; *ｌㅔf:: = \%릭Ⱶᵀ::',
+ },
+) {
+my $prog =    q~
+     BEGIN {
+         unless (-d 'blib') {
+             chdir 't' if -d 't';
+             @INC = '../lib';
+         }
+     }
+     use utf8;
+     use open qw( :utf8 :std );
+
+     @숩cਲꩋ::ISA = "ｌㅔf";
+     @ｌㅔf::ISA = "톺ĺФț";
+
+     sub 톺ĺФț::Ｓᑊeಅḱ { "Woof!" }
+     sub ᴖ릭ᚽʇ::Ｓᑊeಅḱ { "Bow-wow!" }
+
+     my $thing = bless [], "숩cਲꩋ";
+
+     # mro_package_moved needs to know to skip non-globs
+     $릭Ⱶᵀ::{"ᚷꝆエcƙ::"} = 3;
+
+     @릭Ⱶᵀ::ISA = 'ᴖ릭ᚽʇ';
+     my $life_raft;
+    __code__;
+
+     print $thing->Ｓᑊeಅḱ, "\n";
+
+     undef $life_raft;
+     print $thing->Ｓᑊeಅḱ, "\n";
+   ~ =~ s\__code__\$$_{code}\r; #\
+utf8::encode($prog);
+ fresh_perl_is
+  $prog, 
+  "Bow-wow!\nBow-wow!\n",
+   {},
+  "replacing packages by $$_{name} updates isa caches";
+}
+
+# Similar test, but with nested packages
+#
+#  톺ĺФț (Woof)    ᴖ릭ᚽʇ (Bow-wow)
+#      |                 |
+#  ｌㅔf::Side   <-   릭Ⱶᵀ::Side
+#      |
+#   숩cਲꩋ
+#
+# This test assigns 릭Ⱶᵀ:: to ｌㅔf::, indirectly making ｌㅔf::Side an
+# alias to 릭Ⱶᵀ::Side (following the arrow in the diagram).
+for(
+ {
+   name => 'assigning a glob to a glob',
+   code => '$life_raft = $::{"ｌㅔf::"}; *ｌㅔf:: = $::{"릭Ⱶᵀ::"}',
+ },
+ {
+   name => 'assigning a string to a glob',
+   code => '$life_raft = $::{"ｌㅔf::"}; *ｌㅔf:: = "릭Ⱶᵀ::"',
+ },
+ {
+   name => 'assigning a stashref to a glob',
+   code => '$life_raft = \%ｌㅔf::; *ｌㅔf:: = \%릭Ⱶᵀ::',
+ },
+) {
+ my $prog = q~
+     BEGIN {
+         unless (-d 'blib') {
+             chdir 't' if -d 't';
+             @INC = '../lib';
+         }
+     }
+     use utf8;
+     use open qw( :utf8 :std );
+     @숩cਲꩋ::ISA = "ｌㅔf::Side";
+     @ｌㅔf::Side::ISA = "톺ĺФț";
+
+     sub 톺ĺФț::Ｓᑊeಅḱ { "Woof!" }
+     sub ᴖ릭ᚽʇ::Ｓᑊeಅḱ { "Bow-wow!" }
+
+     my $thing = bless [], "숩cਲꩋ";
+
+     @릭Ⱶᵀ::Side::ISA = 'ᴖ릭ᚽʇ';
+     my $life_raft;
+    __code__;
+
+     print $thing->Ｓᑊeಅḱ, "\n";
+
+     undef $life_raft;
+     print $thing->Ｓᑊeಅḱ, "\n";
+   ~ =~ s\__code__\$$_{code}\r;
+ utf8::encode($prog);
+
+ fresh_perl_is
+  $prog,
+  "Bow-wow!\nBow-wow!\n",
+   {},
+  "replacing nested packages by $$_{name} updates isa caches";
+}
+
+# Another nested package test, in which the isa cache needs to be reset on
+# the subclass of a package that does not exist.
+#
+# Parenthesized packages do not exist.
+#
+#  ɵűʇㄦ::인ንʵ    ( cฬnए::인ንʵ )
+#       |                 |
+#     Ｌфť              R익hȚ
+#
+#        ɵűʇㄦ  ->  cฬnए
+#
+# This test assigns ɵűʇㄦ:: to cฬnए::, making cฬnए::인ንʵ an alias to
+# ɵűʇㄦ::인ንʵ.
+#
+# Then we also run the test again, but without ɵűʇㄦ::인ንʵ
+for(
+ {
+   name => 'assigning a glob to a glob',
+   code => '*cฬnए:: = *ɵűʇㄦ::',
+ },
+ {
+   name => 'assigning a string to a glob',
+   code => '*cฬnए:: = "ɵűʇㄦ::"',
+ },
+ {
+   name => 'assigning a stashref to a glob',
+   code => '*cฬnए:: = \%ɵűʇㄦ::',
+ },
+) {
+ for my $tail ('인ንʵ', '인ንʵ::', '인ንʵ:::', '인ንʵ::::') {
+  my $prog =     q~
+     BEGIN {
+         unless (-d 'blib') {
+             chdir 't' if -d 't';
+             @INC = '../lib';
+         }
+     }
+      use utf8;
+      use open qw( :utf8 :std );
+      use Encode ();
+
+      if (grep /\P{ASCII}/, @ARGV) {
+        @ARGV = map { Encode::decode("UTF-8", $_) } @ARGV;
+      }
+
+      my $tail = shift;
+      @Ｌфť::ISA = "ɵűʇㄦ::$tail";
+      @R익hȚ::ISA = "cฬnए::$tail";
+      bless [], "ɵűʇㄦ::$tail"; # autovivify the stash
+
+     __code__;
+
+      print "ok 1", "\n" if Ｌфť->isa("cฬnए::$tail");
+      print "ok 2", "\n" if R익hȚ->isa("ɵűʇㄦ::$tail");
+      print "ok 3", "\n" if R익hȚ->isa("cฬnए::$tail");
+      print "ok 4", "\n" if Ｌфť->isa("ɵűʇㄦ::$tail");
+    ~ =~ s\__code__\$$_{code}\r;
+  utf8::encode($prog);
+  fresh_perl_is
+   $prog,
+   "ok 1\nok 2\nok 3\nok 4\n",
+    { args => [$tail] },
+   "replacing nonexistent nested packages by $$_{name} updates isa caches"
+     ." ($tail)";
+
+  # Same test but with the subpackage autovivified after the assignment
+  $prog =     q~
+      BEGIN {
+         unless (-d 'blib') {
+             chdir 't' if -d 't';
+             @INC = '../lib';
+         }
+      }
+      use utf8;
+      use open qw( :utf8 :std );
+      use Encode ();
+
+      if (grep /\P{ASCII}/, @ARGV) {
+        @ARGV = map { Encode::decode("UTF-8", $_) } @ARGV;
+      }
+
+      my $tail = shift;
+      @Ｌфť::ISA = "ɵűʇㄦ::$tail";
+      @R익hȚ::ISA = "cฬnए::$tail";
+
+     __code__;
+
+      bless [], "ɵűʇㄦ::$tail";
+
+      print "ok 1", "\n" if Ｌфť->isa("cฬnए::$tail");
+      print "ok 2", "\n" if R익hȚ->isa("ɵűʇㄦ::$tail");
+      print "ok 3", "\n" if R익hȚ->isa("cฬnए::$tail");
+      print "ok 4", "\n" if Ｌфť->isa("ɵűʇㄦ::$tail");
+    ~ =~ s\__code__\$$_{code}\r;
+  utf8::encode($prog);
+  fresh_perl_is
+   $prog,
+   "ok 1\nok 2\nok 3\nok 4\n",
+    { args => [$tail] },
+   "Giving nonexistent packages multiple effective names by $$_{name}"
+     . " ($tail)";
+ }
+}
+
+no warnings; # temporary; there seems to be a scoping bug, as this does not
+             # work when placed in the blocks below
+
+# Test that deleting stash elements containing
+# subpackages also invalidates the isa cache.
+# Maybe this does not belong in package_aliases.t, but it is closely
+# related to the tests immediately preceding.
+{
+ @ቹऋ::ISA = ("Cuȓ", "ฮﾝᛞ");
+ @Cuȓ::ISA = "Hyḹ앛Ҭテ";
+
+ sub Hyḹ앛Ҭテ::Ｓᑊeಅḱ { "Arff!" }
+ sub ฮﾝᛞ::Ｓᑊeಅḱ { "Woof!" }
+
+ my $pet = bless [], "ቹऋ";
+
+ my $life_raft = delete $::{'Cuȓ::'};
+
+ is $pet->Ｓᑊeಅḱ, 'Woof!',
+  'deleting a stash from its parent stash invalidates the isa caches';
+
+ undef $life_raft;
+ is $pet->Ｓᑊeಅḱ, 'Woof!',
+  'the deleted stash is gone completely when freed';
+}
+# Same thing, but with nested packages
+{
+ @펱ᑦ::ISA = ("Cuȓȓ::Cuȓȓ::Cuȓȓ", "ɥwn");
+ @Cuȓȓ::Cuȓȓ::Cuȓȓ::ISA = "lȺt랕ᚖ";
+
+ sub lȺt랕ᚖ::Ｓᑊeಅḱ { "Arff!" }
+ sub ɥwn::Ｓᑊeಅḱ { "Woof!" }
+
+ my $pet = bless [], "펱ᑦ";
+
+ my $life_raft = delete $::{'Cuȓȓ::'};
+
+ is $pet->Ｓᑊeಅḱ, 'Woof!',
+  'deleting a stash from its parent stash resets caches of substashes';
+
+ undef $life_raft;
+ is $pet->Ｓᑊeಅḱ, 'Woof!',
+  'the deleted substash is gone completely when freed';
+}
+
+# [perl #77358]
+my $prog =    q~#!perl -w
+     BEGIN {
+         unless (-d 'blib') {
+             chdir 't' if -d 't';
+             @INC = '../lib';
+         }
+     }
+     use utf8;
+     use open qw( :utf8 :std );
+     @펱ᑦ::ISA = "T잌ዕ";
+     @T잌ዕ::ISA = "Bᛆヶṝ";
+     
+     sub Bᛆヶṝ::Ｓᑊeಅḱ { print "Woof!\n" }
+     sub lȺt랕ᚖ::Ｓᑊeಅḱ { print "Bow-wow!\n" }
+     
+     my $pet = bless [], "펱ᑦ";
+     
+     $pet->Ｓᑊeಅḱ;
+     
+     sub ດƓ::Ｓᑊeಅḱ { print "Hello.\n" } # strange ດƓ!
+     @ດƓ::ISA = 'lȺt랕ᚖ';
+     *T잌ዕ:: = delete $::{'ດƓ::'};
+     
+     $pet->Ｓᑊeಅḱ;
+   ~;
+utf8::encode($prog);
+fresh_perl_is
+  $prog,
+  "Woof!\nHello.\n",
+   { stderr => 1 },
+  "Assigning a nameless package over one w/subclasses updates isa caches";
+
+# mro_package_moved needs to make a distinction between replaced and
+# assigned stashes when keeping track of what it has seen so far.
+no warnings; {
+    no strict 'refs';
+
+    sub ʉ::bᓗnǩ::bᓗnǩ::ພo { "bbb" }
+    sub ᵛeↄl움::ພo { "lasrevinu" }
+    @ݏ엗Ƚeᵬૐᵖ::ISA = qw 'ພo::bᓗnǩ::bᓗnǩ ᵛeↄl움';
+    *ພo::ବㄗ:: = *ʉ::bᓗnǩ::;   # now ʉ::bᓗnǩ:: is on both sides
+    *ພo:: = *ʉ::;         # here ʉ::bᓗnǩ:: is both deleted and added
+    *ʉ:: = *ቦᵕ::;          # now it is only known as ພo::bᓗnǩ::
+
+    # At this point, before the bug was fixed, %ພo::bᓗnǩ::bᓗnǩ:: ended
+    # up with no effective name, allowing it to be deleted without updating
+    # its subclasses’ caches.
+
+    my $accum = '';
+
+    $accum .= 'ݏ엗Ƚeᵬૐᵖ'->ພo;          # bbb
+    delete ${"ພo::bᓗnǩ::"}{"bᓗnǩ::"};
+    $accum .= 'ݏ엗Ƚeᵬૐᵖ'->ພo;          # bbb (Oops!)
+    @ݏ엗Ƚeᵬૐᵖ::ISA = @ݏ엗Ƚeᵬૐᵖ::ISA;
+    $accum .= 'ݏ엗Ƚeᵬૐᵖ'->ພo;          # lasrevinu
+
+    is $accum, 'bbblasrevinulasrevinu',
+      'nested classes deleted & added simultaneously';
+}
+use warnings;
+
+# mro_package_moved needs to check for self-referential packages.
+# This broke Text::Template [perl #78362].
+watchdog 3;
+*ᕘ:: = \%::;
+*Aᶜme::Mῌ::Aᶜme:: = \*Aᶜme::; # indirect self-reference
+pass("mro_package_moved and self-referential packages");
+
+# Deleting a glob whose name does not indicate its location in the symbol
+# table but which nonetheless *is* in the symbol table.
+{
+    no strict refs=>;
+    no warnings;
+    @ოƐ::mഒrェ::ISA = "foᚒ";
+    sub foᚒ::ວmᑊ { "aoeaa" }
+    *ťວ:: = *ოƐ::;
+    delete $::{"ოƐ::"};
+    @C힐dᒡl았::ISA = 'ťວ::mഒrェ';
+    my $accum = 'C힐dᒡl았'->ວmᑊ . '-';
+    my $life_raft = delete ${"ťວ::"}{"mഒrェ::"};
+    $accum .= eval { 'C힐dᒡl았'->ວmᑊ } // '<undef>';
+    is $accum, 'aoeaa-<undef>',
+     'Deleting globs whose loc in the symtab differs from gv_fullname'
+}
+
+# Pathological test for undeffing a stash that has an alias.
+*ᵍh엞:: = *ኔƞ::;
+@숩cਲꩋ::ISA = 'ᵍh엞';
+undef %ᵍh엞::;
+sub F렐ᛔ::ວmᑊ { "clumpren" }
+eval '
+  $ኔƞ::whatever++;
+  @ኔƞ::ISA = "F렐ᛔ";
+';
+is eval { '숩cਲꩋ'->ວmᑊ }, 'clumpren',
+ 'Changes to @ISA after undef via original name';
+undef %ᵍh엞::;
+eval '
+  $ᵍh엞::whatever++;
+  @ᵍh엞::ISA = "F렐ᛔ";
+';
+is eval { '숩cਲꩋ'->ວmᑊ }, 'clumpren',
+ 'Changes to @ISA after undef via alias';
+
+
+# Packages whose containing stashes have aliases must lose all names cor-
+# responding to that container when detached.
+{
+ {package śmᛅḙ::በɀ} # autovivify
+ *pḢ린ᚷ:: = *śmᛅḙ::;  # śmᛅḙ::በɀ now also named pḢ린ᚷ::በɀ
+ *본:: = delete $śmᛅḙ::{"በɀ::"};
+ # In 5.13.7, it has now lost its śmᛅḙ::በɀ name (reverting to pḢ린ᚷ::በɀ
+ # as the effective name), and gained 본 as an alias.
+ # In 5.13.8, both śmᛅḙ::በɀ *and* pḢ린ᚷ::በɀ names are deleted.
+
+ # Make some methods
+ no strict 'refs';
+ *{"pḢ린ᚷ::በɀ::fฤmᛈ"} = sub { "hello" };
+ sub Ｆルmፕṟ::fฤmᛈ { "good bye" };
+
+ @ᵇるᣘ킨::ISA = qw "본 Ｆルmፕṟ"; # now wrongly inherits from pḢ린ᚷ::በɀ
+
+ is fฤmᛈ ᵇるᣘ킨, "good bye",
+  'detached stashes lose all names corresponding to the containing stash';
+}
+
+# Crazy edge cases involving packages ending with a single :
+@촐oン::ISA = 'ᚖგ:'; # pun intended!
+bless [], "ᚖგ:"; # autovivify the stash
+ok "촐oン"->isa("ᚖგ:"), 'class isa "class:"';
+{ no strict 'refs'; *{"ᚖგ:::"} = *ᚖგ:: }
+ok "촐oン"->isa("ᚖგ"),
+ 'isa(ᕘ) when inheriting from "class:" which is an alias for ᕘ';
+{
+ no warnings;
+ # The next line of code is *not* normative. If the structure changes,
+ # this line needs to change, too.
+ my $ᕘ = delete $ᚖგ::{":"};
+ ok !촐oン->isa("ᚖგ"),
+  'class that isa "class:" no longer isa ᕘ if "class:" has been deleted';
+}
+@촐oン::ISA = ':';
+bless [], ":";
+ok "촐oン"->isa(":"), 'class isa ":"';
+{ no strict 'refs'; *{":::"} = *ፑňṪu앝ȋ온:: }
+ok "촐oン"->isa("ፑňṪu앝ȋ온"),
+ 'isa(ᕘ) when inheriting from ":" which is an alias for ᕘ';
+@촐oン::ISA = 'ᚖგ:';
+bless [], "ᚖგ:";
+{
+ no strict 'refs';
+ my $life_raft = \%{"ᚖგ:::"};
+ *{"ᚖგ:::"} = \%ᚖგ::;
+ ok "촐oン"->isa("ᚖგ"),
+  'isa(ᕘ) when inheriting from "class:" after hash-to-glob assignment';
+}
+@촐oン::ISA = 'ŏ:';
+bless [], "ŏ:";
+{
+ no strict 'refs';
+ my $life_raft = \%{"ŏ:::"};
+ *{"ŏ:::"} = "ᚖგ::";
+ ok "촐oン"->isa("ᚖგ"),
+  'isa(ᕘ) when inheriting from "class:" after string-to-glob assignment';
+}
+=cut