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

#!./perl

BEGIN {
    unless (-d 'blib') {
        chdir 't' if -d 't';
        @INC = '../lib';
    }
    require q(./test.pl);
}

use strict;
use warnings;
plan(tests => 27);

{
    package New;
    use strict;
    use warnings;

    package Old;
    use strict;
    use warnings;

    {
      no strict 'refs';
      *{'Old::'} = *{'New::'};
    }
}

ok (Old->isa (New::), 'Old inherits from New');
ok (New->isa (Old::), 'New inherits from Old');

isa_ok (bless ({}, Old::), New::, 'Old object');
isa_ok (bless ({}, New::), Old::, 'New 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 = $::{"Left::"}; *Left:: = $::{"Right::"}',
 },
 {
   name => 'assigning a string to a glob',
   code => '$life_raft = $::{"Left::"}; *Left:: = "Right::"',
 },
 {
   name => 'assigning a stashref to a glob',
   code => '$life_raft = \%Left::; *Left:: = \%Right::',
 },
) {
 fresh_perl_is
   q~
     @Subclass::ISA = "Left";
     @Left::ISA = "TopLeft";

     sub TopLeft::speak { "Woof!" }
     sub TopRight::speak { "Bow-wow!" }

     my $thing = bless [], "Subclass";

     # mro_package_moved needs to know to skip non-globs
     $Right::{"gleck::"} = 3;

     @Right::ISA = 'TopRight';
     my $life_raft;
    __code__;

     print $thing->speak, "\n";

     undef $life_raft;
     print $thing->speak, "\n";
   ~ =~ s\__code__\$$_{code}\r,
  "Bow-wow!\nBow-wow!\n",
   {},
  "replacing packages by $$_{name} updates isa caches";
}

# Similar test, but with nested packages
#
#  TopLeft (Woof)    TopRight (Bow-wow)
#      |                 |
#  Left::Side   <-   Right::Side
#      |
#   Subclass
#
# This test assigns Right:: to Left::, indirectly making Left::Side an
# alias to Right::Side (following the arrow in the diagram).
for(
 {
   name => 'assigning a glob to a glob',
   code => '$life_raft = $::{"Left::"}; *Left:: = $::{"Right::"}',
 },
 {
   name => 'assigning a string to a glob',
   code => '$life_raft = $::{"Left::"}; *Left:: = "Right::"',
 },
 {
   name => 'assigning a stashref to a glob',
   code => '$life_raft = \%Left::; *Left:: = \%Right::',
 },
) {
 fresh_perl_is
   q~
     @Subclass::ISA = "Left::Side";
     @Left::Side::ISA = "TopLeft";

     sub TopLeft::speak { "Woof!" }
     sub TopRight::speak { "Bow-wow!" }

     my $thing = bless [], "Subclass";

     @Right::Side::ISA = 'TopRight';
     my $life_raft;
    __code__;

     print $thing->speak, "\n";

     undef $life_raft;
     print $thing->speak, "\n";
   ~ =~ s\__code__\$$_{code}\r,
  "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.
#
#  outer::inner    ( clone::inner )
#       |                 |
#     left              right
#
#        outer  ->  clone
#
# This test assigns outer:: to clone::, making clone::inner an alias to
# outer::inner.
#
# Then we also run the test again, but without outer::inner
for(
 {
   name => 'assigning a glob to a glob',
   code => '*clone:: = *outer::',
 },
 {
   name => 'assigning a string to a glob',
   code => '*clone:: = "outer::"',
 },
 {
   name => 'assigning a stashref to a glob',
   code => '*clone:: = \%outer::',
 },
) {
 fresh_perl_is
   q~
     @left::ISA = 'outer::inner';
     @right::ISA = 'clone::inner';
     {package outer::inner}

    __code__;

     print "ok 1", "\n" if left->isa("clone::inner");
     print "ok 2", "\n" if right->isa("outer::inner");
   ~ =~ s\__code__\$$_{code}\r,
  "ok 1\nok 2\n",
   {},
  "replacing nonexistent nested packages by $$_{name} updates isa caches";

 # Same test but with the subpackage autovivified after the assignment
 fresh_perl_is
   q~
     @left::ISA = 'outer::inner';
     @right::ISA = 'clone::inner';

    __code__;

     eval q{package outer::inner};

     print "ok 1", "\n" if left->isa("clone::inner");
     print "ok 2", "\n" if right->isa("outer::inner");
   ~ =~ s\__code__\$$_{code}\r,
  "ok 1\nok 2\n",
   {},
  "Giving nonexistent packages multiple effective names by $$_{name}";
}

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.
{
 @Pet::ISA = ("Cur", "Hound");
 @Cur::ISA = "Hylactete";

 sub Hylactete::speak { "Arff!" }
 sub Hound::speak { "Woof!" }

 my $pet = bless [], "Pet";

 my $life_raft = delete $::{'Cur::'};

 is $pet->speak, 'Woof!',
  'deleting a stash from its parent stash invalidates the isa caches';

 undef $life_raft;
 is $pet->speak, 'Woof!',
  'the deleted stash is gone completely when freed';
}
# Same thing, but with nested packages
{
 @Pett::ISA = ("Curr::Curr::Curr", "Hownd");
 @Curr::Curr::Curr::ISA = "Latrator";

 sub Latrator::speak { "Arff!" }
 sub Hownd::speak { "Woof!" }

 my $pet = bless [], "Pett";

 my $life_raft = delete $::{'Curr::'};

 is $pet->speak, 'Woof!',
  'deleting a stash from its parent stash resets caches of substashes';

 undef $life_raft;
 is $pet->speak, 'Woof!',
  'the deleted substash is gone completely when freed';
}

# [perl #77358]
fresh_perl_is
   q~#!perl -w
     @Pet::ISA = "Tike";
     @Tike::ISA = "Barker";
     
     sub Barker::speak { print "Woof!\n" }
     sub Latrator::speak { print "Bow-wow!\n" }
     
     my $pet = bless [], "Pet";
     
     $pet->speak;
     
     sub Dog::speak { print "Hello.\n" } # strange dog!
     @Dog::ISA = 'Latrator';
     *Tike:: = delete $::{'Dog::'};
     
     $pet->speak;
   ~,
  "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 bar::blonk::blonk::phoo { "bbb" }
    sub veclum::phoo { "lasrevinu" }
    @feedlebomp::ISA = qw 'phoo::blonk::blonk veclum';
    *phoo::baz:: = *bar::blonk::;   # now bar::blonk:: is on both sides
    *phoo:: = *bar::;         # here bar::blonk:: is both deleted and added
    *bar:: = *boo::;          # now it is only known as phoo::blonk::

    # At this point, before the bug was fixed, %phoo::blonk::blonk:: ended
    # up with no effective name, allowing it to be deleted without updating
    # its subclasses’ caches.

    my $accum = '';

    $accum .= 'feedlebomp'->phoo;          # bbb
    delete ${"phoo::blonk::"}{"blonk::"};
    $accum .= 'feedlebomp'->phoo;          # bbb (Oops!)
    @feedlebomp::ISA = @feedlebomp::ISA;
    $accum .= 'feedlebomp'->phoo;          # 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;
*foo:: = \%::;
*Acme::META::Acme:: = \*Acme::; # 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;
    @one::more::ISA = "four";
    sub four::womp { "aoeaa" }
    *two:: = *one::;
    delete $::{"one::"};
    @Childclass::ISA = 'two::more';
    my $accum = 'Childclass'->womp . '-';
    my $life_raft = delete ${"two::"}{"more::"};
    $accum .= eval { 'Childclass'->womp } // '<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.
*Ghelp:: = *Neen::;
@Subclass::ISA = 'Ghelp';
undef %Ghelp::;
sub Frelp::womp { "clumpren" }
eval '
  $Neen::whatever++;
  @Neen::ISA = "Frelp";
';
is eval { 'Subclass'->womp }, 'clumpren',
 'Changes to @ISA after undef via original name';
undef %Ghelp::;
eval '
  $Ghelp::whatever++;
  @Ghelp::ISA = "Frelp";
';
is eval { 'Subclass'->womp }, '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 smare::baz} # autovivify
 *phring:: = *smare::;  # smare::baz now also named phring::baz
 *bonk:: = delete $smare::{"baz::"};
 # In 5.13.7, it has now lost its smare::baz name (reverting to phring::baz
 # as the effective name), and gained bonk as an alias.
 # In 5.13.8, both smare::baz *and* phring::baz names are deleted.

 # Make some methods
 no strict 'refs';
 *{"phring::baz::frump"} = sub { "hello" };
 sub frumper::frump { "good bye" };

 @brumkin::ISA = qw "bonk frumper"; # now wrongly inherits from phring::baz

 is frump brumkin, "good bye",
  'detached stashes lose all names corresponding to the containing stash';
}
Commit	Line	Data
0643ac23 TS	1	#!./perl
	2
	3	BEGIN {
	4	unless (-d 'blib') {
	5	chdir 't' if -d 't';
	6	@INC = '../lib';
	7	}
c8bbf675	8	require q(./test.pl);
0643ac23 TS	9	}
	10
	11	use strict;
	12	use warnings;
298d6511	13	plan(tests => 27);
0643ac23 TS	14
	15	{
	16	package New;
	17	use strict;
	18	use warnings;
	19
	20	package Old;
	21	use strict;
	22	use warnings;
	23
	24	{
	25	no strict 'refs';
	26	{'Old::'} = {'New::'};
	27	}
	28	}
	29
	30	ok (Old->isa (New::), 'Old inherits from New');
	31	ok (New->isa (Old::), 'New inherits from Old');
	32
	33	isa_ok (bless ({}, Old::), New::, 'Old object');
	34	isa_ok (bless ({}, New::), Old::, 'New object');
c8bbf675 FC	35
c8bbf675 FC	36
c8bbf675 FC	37	# Test that replacing a package by assigning to an existing glob
c8bbf675 FC	38	# invalidates the isa caches
3e79609f FC	39	for(
	40	{
	41	name => 'assigning a glob to a glob',
	42	code => '$life_raft = $::{"Left::"}; *Left:: = $::{"Right::"}',
	43	},
	44	{
	45	name => 'assigning a string to a glob',
	46	code => '$life_raft = $::{"Left::"}; *Left:: = "Right::"',
	47	},
	48	{
	49	name => 'assigning a stashref to a glob',
	50	code => '$life_raft = \%Left::; *Left:: = \%Right::',
	51	},
	52	) {
	53	fresh_perl_is
	54	q~
	55	@Subclass::ISA = "Left";
	56	@Left::ISA = "TopLeft";
	57
	58	sub TopLeft::speak { "Woof!" }
	59	sub TopRight::speak { "Bow-wow!" }
	60
	61	my $thing = bless [], "Subclass";
	62
	63	# mro_package_moved needs to know to skip non-globs
	64	$Right::{"gleck::"} = 3;
	65
	66	@Right::ISA = 'TopRight';
	67	my $life_raft;
	68	__code__;
	69
	70	print $thing->speak, "\n";
	71
	72	undef $life_raft;
	73	print $thing->speak, "\n";
	74	~ =~ s\__code__\$$_{code}\r,
	75	"Bow-wow!\nBow-wow!\n",
	76	{},
	77	"replacing packages by $$_{name} updates isa caches";
c8bbf675 FC	78	}
	79
	80	# Similar test, but with nested packages
54b65169 FC	81	#
	82	# TopLeft (Woof) TopRight (Bow-wow)
	83	# \| \|
	84	# Left::Side <- Right::Side
	85	# \|
	86	# Subclass
	87	#
	88	# This test assigns Right:: to Left::, indirectly making Left::Side an
	89	# alias to Right::Side (following the arrow in the diagram).
3e79609f FC	90	for(
	91	{
	92	name => 'assigning a glob to a glob',
	93	code => '$life_raft = $::{"Left::"}; *Left:: = $::{"Right::"}',
	94	},
	95	{
	96	name => 'assigning a string to a glob',
	97	code => '$life_raft = $::{"Left::"}; *Left:: = "Right::"',
	98	},
	99	{
	100	name => 'assigning a stashref to a glob',
	101	code => '$life_raft = \%Left::; *Left:: = \%Right::',
	102	},
	103	) {
	104	fresh_perl_is
	105	q~
	106	@Subclass::ISA = "Left::Side";
	107	@Left::Side::ISA = "TopLeft";
	108
	109	sub TopLeft::speak { "Woof!" }
	110	sub TopRight::speak { "Bow-wow!" }
	111
	112	my $thing = bless [], "Subclass";
	113
	114	@Right::Side::ISA = 'TopRight';
	115	my $life_raft;
	116	__code__;
	117
	118	print $thing->speak, "\n";
	119
	120	undef $life_raft;
	121	print $thing->speak, "\n";
	122	~ =~ s\__code__\$$_{code}\r,
	123	"Bow-wow!\nBow-wow!\n",
	124	{},
	125	"replacing nested packages by $$_{name} updates isa caches";
c8bbf675 FC	126	}
c8bbf675 FC	127
d056e33c FC	128	# Another nested package test, in which the isa cache needs to be reset on
	129	# the subclass of a package that does not exist.
	130	#
	131	# Parenthesized packages do not exist.
	132	#
	133	# outer::inner ( clone::inner )
	134	# \| \|
	135	# left right
	136	#
	137	# outer -> clone
	138	#
	139	# This test assigns outer:: to clone::, making clone::inner an alias to
	140	# outer::inner.
298d6511 FC	141	#
298d6511 FC	142	# Then we also run the test again, but without outer::inner
d056e33c FC	143	for(
	144	{
	145	name => 'assigning a glob to a glob',
	146	code => 'clone:: = outer::',
	147	},
	148	{
	149	name => 'assigning a string to a glob',
	150	code => '*clone:: = "outer::"',
	151	},
	152	{
	153	name => 'assigning a stashref to a glob',
	154	code => '*clone:: = \%outer::',
	155	},
	156	) {
	157	fresh_perl_is
	158	q~
	159	@left::ISA = 'outer::inner';
	160	@right::ISA = 'clone::inner';
	161	{package outer::inner}
	162
	163	__code__;
	164
	165	print "ok 1", "\n" if left->isa("clone::inner");
	166	print "ok 2", "\n" if right->isa("outer::inner");
	167	~ =~ s\__code__\$$_{code}\r,
	168	"ok 1\nok 2\n",
	169	{},
	170	"replacing nonexistent nested packages by $$_{name} updates isa caches";
298d6511 FC	171
	172	# Same test but with the subpackage autovivified after the assignment
	173	fresh_perl_is
	174	q~
	175	@left::ISA = 'outer::inner';
	176	@right::ISA = 'clone::inner';
	177
	178	__code__;
	179
	180	eval q{package outer::inner};
	181
	182	print "ok 1", "\n" if left->isa("clone::inner");
	183	print "ok 2", "\n" if right->isa("outer::inner");
	184	~ =~ s\__code__\$$_{code}\r,
	185	"ok 1\nok 2\n",
	186	{},
	187	"Giving nonexistent packages multiple effective names by $$_{name}";
d056e33c FC	188	}
d056e33c FC	189
0d93988a FC	190	no warnings; # temporary; there seems to be a scoping bug, as this does not
	191	# work when placed in the blocks below
	192
c8bbf675 FC	193	# Test that deleting stash elements containing
	194	# subpackages also invalidates the isa cache.
	195	# Maybe this does not belong in package_aliases.t, but it is closely
	196	# related to the tests immediately preceding.
	197	{
	198	@Pet::ISA = ("Cur", "Hound");
	199	@Cur::ISA = "Hylactete";
	200
	201	sub Hylactete::speak { "Arff!" }
	202	sub Hound::speak { "Woof!" }
	203
	204	my $pet = bless [], "Pet";
	205
	206	my $life_raft = delete $::{'Cur::'};
	207
	208	is $pet->speak, 'Woof!',
	209	'deleting a stash from its parent stash invalidates the isa caches';
	210
	211	undef $life_raft;
	212	is $pet->speak, 'Woof!',
	213	'the deleted stash is gone completely when freed';
	214	}
4f6b8b29 FC	215	# Same thing, but with nested packages
	216	{
	217	@Pett::ISA = ("Curr::Curr::Curr", "Hownd");
	218	@Curr::Curr::Curr::ISA = "Latrator";
	219
	220	sub Latrator::speak { "Arff!" }
	221	sub Hownd::speak { "Woof!" }
	222
	223	my $pet = bless [], "Pett";
	224
	225	my $life_raft = delete $::{'Curr::'};
	226
	227	is $pet->speak, 'Woof!',
	228	'deleting a stash from its parent stash resets caches of substashes';
	229
	230	undef $life_raft;
	231	is $pet->speak, 'Woof!',
	232	'the deleted substash is gone completely when freed';
	233	}
	234
0d93988a FC	235	# [perl #77358]
	236	fresh_perl_is
	237	q~#!perl -w
	238	@Pet::ISA = "Tike";
	239	@Tike::ISA = "Barker";
	240
	241	sub Barker::speak { print "Woof!\n" }
	242	sub Latrator::speak { print "Bow-wow!\n" }
	243
	244	my $pet = bless [], "Pet";
	245
	246	$pet->speak;
	247
	248	sub Dog::speak { print "Hello.\n" } # strange dog!
	249	@Dog::ISA = 'Latrator';
	250	*Tike:: = delete $::{'Dog::'};
	251
	252	$pet->speak;
	253	~,
	254	"Woof!\nHello.\n",
	255	{ stderr => 1 },
	256	"Assigning a nameless package over one w/subclasses updates isa caches";
	257
b89cdb22 FC	258	# mro_package_moved needs to make a distinction between replaced and
	259	# assigned stashes when keeping track of what it has seen so far.
	260	no warnings; {
	261	no strict 'refs';
	262
	263	sub bar::blonk::blonk::phoo { "bbb" }
	264	sub veclum::phoo { "lasrevinu" }
	265	@feedlebomp::ISA = qw 'phoo::blonk::blonk veclum';
	266	phoo::baz:: = bar::blonk::; # now bar::blonk:: is on both sides
	267	phoo:: = bar::; # here bar::blonk:: is both deleted and added
	268	bar:: = boo::; # now it is only known as phoo::blonk::
	269
	270	# At this point, before the bug was fixed, %phoo::blonk::blonk:: ended
	271	# up with no effective name, allowing it to be deleted without updating
	272	# its subclasses’ caches.
	273
	274	my $accum = '';
	275
	276	$accum .= 'feedlebomp'->phoo; # bbb
	277	delete ${"phoo::blonk::"}{"blonk::"};
	278	$accum .= 'feedlebomp'->phoo; # bbb (Oops!)
	279	@feedlebomp::ISA = @feedlebomp::ISA;
	280	$accum .= 'feedlebomp'->phoo; # lasrevinu
	281
	282	is $accum, 'bbblasrevinulasrevinu',
	283	'nested classes deleted & added simultaneously';
	284	}
	285	use warnings;
62c1e33f FC	286
	287	# mro_package_moved needs to check for self-referential packages.
	288	# This broke Text::Template [perl #78362].
	289	watchdog 3;
	290	*foo:: = \%::;
	291	Acme::META::Acme:: = \Acme::; # indirect self-reference
	292	pass("mro_package_moved and self-referential packages");
0290c710 FC	293
	294	# Deleting a glob whose name does not indicate its location in the symbol
	295	# table but which nonetheless is in the symbol table.
	296	{
	297	no strict refs=>;
	298	no warnings;
	299	@one::more::ISA = "four";
	300	sub four::womp { "aoeaa" }
	301	two:: = one::;
	302	delete $::{"one::"};
	303	@Childclass::ISA = 'two::more';
	304	my $accum = 'Childclass'->womp . '-';
	305	my $life_raft = delete ${"two::"}{"more::"};
	306	$accum .= eval { 'Childclass'->womp } // '<undef>';
	307	is $accum, 'aoeaa-<undef>',
	308	'Deleting globs whose loc in the symtab differs from gv_fullname'
	309	}
745edda6 FC	310
	311	# Pathological test for undeffing a stash that has an alias.
	312	Ghelp:: = Neen::;
	313	@Subclass::ISA = 'Ghelp';
	314	undef %Ghelp::;
	315	sub Frelp::womp { "clumpren" }
	316	eval '
	317	$Neen::whatever++;
	318	@Neen::ISA = "Frelp";
	319	';
	320	is eval { 'Subclass'->womp }, 'clumpren',
	321	'Changes to @ISA after undef via original name';
	322	undef %Ghelp::;
	323	eval '
	324	$Ghelp::whatever++;
	325	@Ghelp::ISA = "Frelp";
	326	';
	327	is eval { 'Subclass'->womp }, 'clumpren',
	328	'Changes to @ISA after undef via alias';
d7879cf0 FC	329
	330
	331	# Packages whose containing stashes have aliases must lose all names cor-
	332	# responding to that container when detached.
	333	{
	334	{package smare::baz} # autovivify
	335	phring:: = smare::; # smare::baz now also named phring::baz
	336	*bonk:: = delete $smare::{"baz::"};
	337	# In 5.13.7, it has now lost its smare::baz name (reverting to phring::baz
	338	# as the effective name), and gained bonk as an alias.
	339	# In 5.13.8, both smare::baz and phring::baz names are deleted.
	340
	341	# Make some methods
	342	no strict 'refs';
	343	*{"phring::baz::frump"} = sub { "hello" };
	344	sub frumper::frump { "good bye" };
	345
	346	@brumkin::ISA = qw "bonk frumper"; # now wrongly inherits from phring::baz
	347
	348	is frump brumkin, "good bye",
	349	'detached stashes lose all names corresponding to the containing stash';
	350	}