[perl5.git] / t / mro / package_aliases_utf8.t

#!./perl

BEGIN {
    $ENV{PERL_UNICODE} = 0;
    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ㄉ');

object_ok (bless ({}, ऑlㄉ::), Ｎeẁ::, 'ऑlㄉ object');
object_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â\80\99 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
Commit	Line	Data
204e6232 BF	1	#!./perl
	2
	3	BEGIN {
5b8bb896	4	$ENV{PERL_UNICODE} = 0;
204e6232 BF	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
bbce3ca6 MS	37	object_ok (bless ({}, ऑlㄉ::), Ｎeẁ::, 'ऑlㄉ object');
bbce3ca6 MS	38	object_ok (bless ({}, Ｎeẁ::), ऑlㄉ::, 'Ｎeẁ object');
204e6232 BF	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