1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
#!./perl
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
}
require q(./test.pl);
}
use strict;
use warnings;
plan(tests => 12);
{
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');
no warnings; # temporary, until bug #77358 is fixed
# 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
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";
}
# 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';
}
|
