This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix two minor bugs with local glob assignment
[perl5.git] / t / mro / package_aliases.t
CommitLineData
0643ac23
TS
1#!./perl
2
3BEGIN {
4 unless (-d 'blib') {
5 chdir 't' if -d 't';
6 @INC = '../lib';
7 }
c8bbf675 8 require q(./test.pl);
0643ac23
TS
9}
10
11use strict;
12use warnings;
6e1b2de7 13plan(tests => 53);
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
30ok (Old->isa (New::), 'Old inherits from New');
31ok (New->isa (Old::), 'New inherits from Old');
32
bbce3ca6
MS
33object_ok (bless ({}, Old::), New::, 'Old object');
34object_ok (bless ({}, New::), Old::, 'New object');
c8bbf675
FC
35
36
c8bbf675
FC
37# Test that replacing a package by assigning to an existing glob
38# invalidates the isa caches
3e79609f
FC
39for(
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
90for(
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}
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#
142# Then we also run the test again, but without outer::inner
d056e33c
FC
143for(
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) {
1f656fcf 157 for my $tail ('inner', 'inner::', 'inner:::', 'inner::::') {
088225fd
FC
158 fresh_perl_is
159 q~
160 my $tail = shift;
161 @left::ISA = "outer::$tail";
162 @right::ISA = "clone::$tail";
1f656fcf 163 bless [], "outer::$tail"; # autovivify the stash
088225fd
FC
164
165 __code__;
166
167 print "ok 1", "\n" if left->isa("clone::$tail");
168 print "ok 2", "\n" if right->isa("outer::$tail");
169 print "ok 3", "\n" if right->isa("clone::$tail");
170 print "ok 4", "\n" if left->isa("outer::$tail");
171 ~ =~ s\__code__\$$_{code}\r,
172 "ok 1\nok 2\nok 3\nok 4\n",
173 { args => [$tail] },
174 "replacing nonexistent nested packages by $$_{name} updates isa caches"
175 ." ($tail)";
176
177 # Same test but with the subpackage autovivified after the assignment
178 fresh_perl_is
179 q~
180 my $tail = shift;
181 @left::ISA = "outer::$tail";
182 @right::ISA = "clone::$tail";
183
184 __code__;
185
1f656fcf 186 bless [], "outer::$tail";
088225fd
FC
187
188 print "ok 1", "\n" if left->isa("clone::$tail");
189 print "ok 2", "\n" if right->isa("outer::$tail");
190 print "ok 3", "\n" if right->isa("clone::$tail");
191 print "ok 4", "\n" if left->isa("outer::$tail");
192 ~ =~ s\__code__\$$_{code}\r,
193 "ok 1\nok 2\nok 3\nok 4\n",
194 { args => [$tail] },
195 "Giving nonexistent packages multiple effective names by $$_{name}"
196 . " ($tail)";
197 }
d056e33c
FC
198}
199
0d93988a
FC
200no warnings; # temporary; there seems to be a scoping bug, as this does not
201 # work when placed in the blocks below
202
c8bbf675
FC
203# Test that deleting stash elements containing
204# subpackages also invalidates the isa cache.
205# Maybe this does not belong in package_aliases.t, but it is closely
206# related to the tests immediately preceding.
207{
208 @Pet::ISA = ("Cur", "Hound");
209 @Cur::ISA = "Hylactete";
210
211 sub Hylactete::speak { "Arff!" }
212 sub Hound::speak { "Woof!" }
213
214 my $pet = bless [], "Pet";
215
216 my $life_raft = delete $::{'Cur::'};
217
218 is $pet->speak, 'Woof!',
219 'deleting a stash from its parent stash invalidates the isa caches';
220
221 undef $life_raft;
222 is $pet->speak, 'Woof!',
223 'the deleted stash is gone completely when freed';
224}
4f6b8b29
FC
225# Same thing, but with nested packages
226{
227 @Pett::ISA = ("Curr::Curr::Curr", "Hownd");
228 @Curr::Curr::Curr::ISA = "Latrator";
229
230 sub Latrator::speak { "Arff!" }
231 sub Hownd::speak { "Woof!" }
232
233 my $pet = bless [], "Pett";
234
235 my $life_raft = delete $::{'Curr::'};
236
237 is $pet->speak, 'Woof!',
238 'deleting a stash from its parent stash resets caches of substashes';
239
240 undef $life_raft;
241 is $pet->speak, 'Woof!',
242 'the deleted substash is gone completely when freed';
243}
244
0d93988a
FC
245# [perl #77358]
246fresh_perl_is
247 q~#!perl -w
248 @Pet::ISA = "Tike";
249 @Tike::ISA = "Barker";
250
251 sub Barker::speak { print "Woof!\n" }
252 sub Latrator::speak { print "Bow-wow!\n" }
253
254 my $pet = bless [], "Pet";
255
256 $pet->speak;
257
258 sub Dog::speak { print "Hello.\n" } # strange dog!
259 @Dog::ISA = 'Latrator';
260 *Tike:: = delete $::{'Dog::'};
261
262 $pet->speak;
263 ~,
264 "Woof!\nHello.\n",
265 { stderr => 1 },
266 "Assigning a nameless package over one w/subclasses updates isa caches";
267
b89cdb22
FC
268# mro_package_moved needs to make a distinction between replaced and
269# assigned stashes when keeping track of what it has seen so far.
270no warnings; {
271 no strict 'refs';
272
273 sub bar::blonk::blonk::phoo { "bbb" }
274 sub veclum::phoo { "lasrevinu" }
275 @feedlebomp::ISA = qw 'phoo::blonk::blonk veclum';
276 *phoo::baz:: = *bar::blonk::; # now bar::blonk:: is on both sides
277 *phoo:: = *bar::; # here bar::blonk:: is both deleted and added
278 *bar:: = *boo::; # now it is only known as phoo::blonk::
279
280 # At this point, before the bug was fixed, %phoo::blonk::blonk:: ended
281 # up with no effective name, allowing it to be deleted without updating
282 # its subclasses’ caches.
283
284 my $accum = '';
285
286 $accum .= 'feedlebomp'->phoo; # bbb
287 delete ${"phoo::blonk::"}{"blonk::"};
288 $accum .= 'feedlebomp'->phoo; # bbb (Oops!)
289 @feedlebomp::ISA = @feedlebomp::ISA;
290 $accum .= 'feedlebomp'->phoo; # lasrevinu
291
292 is $accum, 'bbblasrevinulasrevinu',
293 'nested classes deleted & added simultaneously';
294}
295use warnings;
62c1e33f
FC
296
297# mro_package_moved needs to check for self-referential packages.
298# This broke Text::Template [perl #78362].
299watchdog 3;
300*foo:: = \%::;
301*Acme::META::Acme:: = \*Acme::; # indirect self-reference
302pass("mro_package_moved and self-referential packages");
0290c710
FC
303
304# Deleting a glob whose name does not indicate its location in the symbol
305# table but which nonetheless *is* in the symbol table.
306{
307 no strict refs=>;
308 no warnings;
309 @one::more::ISA = "four";
310 sub four::womp { "aoeaa" }
311 *two:: = *one::;
312 delete $::{"one::"};
313 @Childclass::ISA = 'two::more';
314 my $accum = 'Childclass'->womp . '-';
315 my $life_raft = delete ${"two::"}{"more::"};
316 $accum .= eval { 'Childclass'->womp } // '<undef>';
317 is $accum, 'aoeaa-<undef>',
318 'Deleting globs whose loc in the symtab differs from gv_fullname'
319}
745edda6
FC
320
321# Pathological test for undeffing a stash that has an alias.
322*Ghelp:: = *Neen::;
323@Subclass::ISA = 'Ghelp';
324undef %Ghelp::;
325sub Frelp::womp { "clumpren" }
326eval '
327 $Neen::whatever++;
328 @Neen::ISA = "Frelp";
329';
330is eval { 'Subclass'->womp }, 'clumpren',
331 'Changes to @ISA after undef via original name';
332undef %Ghelp::;
333eval '
334 $Ghelp::whatever++;
335 @Ghelp::ISA = "Frelp";
336';
337is eval { 'Subclass'->womp }, 'clumpren',
338 'Changes to @ISA after undef via alias';
d7879cf0
FC
339
340
341# Packages whose containing stashes have aliases must lose all names cor-
342# responding to that container when detached.
343{
344 {package smare::baz} # autovivify
345 *phring:: = *smare::; # smare::baz now also named phring::baz
346 *bonk:: = delete $smare::{"baz::"};
347 # In 5.13.7, it has now lost its smare::baz name (reverting to phring::baz
348 # as the effective name), and gained bonk as an alias.
349 # In 5.13.8, both smare::baz *and* phring::baz names are deleted.
350
351 # Make some methods
352 no strict 'refs';
353 *{"phring::baz::frump"} = sub { "hello" };
354 sub frumper::frump { "good bye" };
355
356 @brumkin::ISA = qw "bonk frumper"; # now wrongly inherits from phring::baz
357
358 is frump brumkin, "good bye",
359 'detached stashes lose all names corresponding to the containing stash';
360}
1f656fcf
FC
361
362# Crazy edge cases involving packages ending with a single :
363@Colon::ISA = 'Organ:'; # pun intended!
364bless [], "Organ:"; # autovivify the stash
365ok "Colon"->isa("Organ:"), 'class isa "class:"';
366{ no strict 'refs'; *{"Organ:::"} = *Organ:: }
367ok "Colon"->isa("Organ"),
368 'isa(foo) when inheriting from "class:" which is an alias for foo';
369{
370 no warnings;
371 # The next line of code is *not* normative. If the structure changes,
372 # this line needs to change, too.
373 my $foo = delete $Organ::{":"};
374 ok !Colon->isa("Organ"),
375 'class that isa "class:" no longer isa foo if "class:" has been deleted';
376}
377@Colon::ISA = ':';
378bless [], ":";
379ok "Colon"->isa(":"), 'class isa ":"';
380{ no strict 'refs'; *{":::"} = *Punctuation:: }
381ok "Colon"->isa("Punctuation"),
382 'isa(foo) when inheriting from ":" which is an alias for foo';
383@Colon::ISA = 'Organ:';
384bless [], "Organ:";
385{
386 no strict 'refs';
387 my $life_raft = \%{"Organ:::"};
388 *{"Organ:::"} = \%Organ::;
389 ok "Colon"->isa("Organ"),
390 'isa(foo) when inheriting from "class:" after hash-to-glob assignment';
391}
392@Colon::ISA = 'O:';
393bless [], "O:";
394{
395 no strict 'refs';
396 my $life_raft = \%{"O:::"};
397 *{"O:::"} = "Organ::";
398 ok "Colon"->isa("Organ"),
399 'isa(foo) when inheriting from "class:" after string-to-glob assignment';
400}
401
6e1b2de7
FC
402@Bazo::ISA = "Fooo::bar";
403sub Fooo::bar::ber { 'baz' }
404sub UNIVERSAL::ber { "black sheep" }
405Bazo->ber;
406local *Fooo:: = \%Baro::;
407{
408 no warnings;
409 is 'Bazo'->ber, 'black sheep', 'localised *glob=$stashref assignment';
410}