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
1 #!./perl
2
3 BEGIN {
4     unless (-d 'blib') {
5         chdir 't' if -d 't';
6         @INC = '../lib';
7     }
8     require q(./test.pl);
9 }
10
11 use strict;
12 use warnings;
13 plan(tests => 53);
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 object_ok (bless ({}, Old::), New::, 'Old object');
34 object_ok (bless ({}, New::), Old::, 'New object');
35
36
37 # Test that replacing a package by assigning to an existing glob
38 # invalidates the isa caches
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";
78 }
79
80 # Similar test, but with nested packages
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).
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";
126 }
127
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.
141 #
142 # Then we also run the test again, but without outer::inner
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  for my $tail ('inner', 'inner::', 'inner:::', 'inner::::') {
158   fresh_perl_is
159     q~
160       my $tail = shift;
161       @left::ISA = "outer::$tail";
162       @right::ISA = "clone::$tail";
163       bless [], "outer::$tail"; # autovivify the stash
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
186       bless [], "outer::$tail";
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  }
198 }
199
200 no warnings; # temporary; there seems to be a scoping bug, as this does not
201              # work when placed in the blocks below
202
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 }
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
245 # [perl #77358]
246 fresh_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
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.
270 no 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 }
295 use warnings;
296
297 # mro_package_moved needs to check for self-referential packages.
298 # This broke Text::Template [perl #78362].
299 watchdog 3;
300 *foo:: = \%::;
301 *Acme::META::Acme:: = \*Acme::; # indirect self-reference
302 pass("mro_package_moved and self-referential packages");
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 }
320
321 # Pathological test for undeffing a stash that has an alias.
322 *Ghelp:: = *Neen::;
323 @Subclass::ISA = 'Ghelp';
324 undef %Ghelp::;
325 sub Frelp::womp { "clumpren" }
326 eval '
327   $Neen::whatever++;
328   @Neen::ISA = "Frelp";
329 ';
330 is eval { 'Subclass'->womp }, 'clumpren',
331  'Changes to @ISA after undef via original name';
332 undef %Ghelp::;
333 eval '
334   $Ghelp::whatever++;
335   @Ghelp::ISA = "Frelp";
336 ';
337 is eval { 'Subclass'->womp }, 'clumpren',
338  'Changes to @ISA after undef via alias';
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 }
361
362 # Crazy edge cases involving packages ending with a single :
363 @Colon::ISA = 'Organ:'; # pun intended!
364 bless [], "Organ:"; # autovivify the stash
365 ok "Colon"->isa("Organ:"), 'class isa "class:"';
366 { no strict 'refs'; *{"Organ:::"} = *Organ:: }
367 ok "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 = ':';
378 bless [], ":";
379 ok "Colon"->isa(":"), 'class isa ":"';
380 { no strict 'refs'; *{":::"} = *Punctuation:: }
381 ok "Colon"->isa("Punctuation"),
382  'isa(foo) when inheriting from ":" which is an alias for foo';
383 @Colon::ISA = 'Organ:';
384 bless [], "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:';
393 bless [], "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
402 @Bazo::ISA = "Fooo::bar";
403 sub Fooo::bar::ber { 'baz' }
404 sub UNIVERSAL::ber { "black sheep" }
405 Bazo->ber;
406 local *Fooo:: = \%Baro::;
407 {
408     no warnings;
409     is 'Bazo'->ber, 'black sheep', 'localised *glob=$stashref assignment';
410 }