This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix package assignment with nested aliased packages
[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 => 20);
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');
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 for(
142  {
143    name => 'assigning a glob to a glob',
144    code => '*clone:: = *outer::',
145  },
146  {
147    name => 'assigning a string to a glob',
148    code => '*clone:: = "outer::"',
149  },
150  {
151    name => 'assigning a stashref to a glob',
152    code => '*clone:: = \%outer::',
153  },
154 ) {
155  fresh_perl_is
156    q~
157      @left::ISA = 'outer::inner';
158      @right::ISA = 'clone::inner';
159      {package outer::inner}
160
161     __code__;
162
163      print "ok 1", "\n" if left->isa("clone::inner");
164      print "ok 2", "\n" if right->isa("outer::inner");
165    ~ =~ s\__code__\$$_{code}\r,
166   "ok 1\nok 2\n",
167    {},
168   "replacing nonexistent nested packages by $$_{name} updates isa caches";
169 }
170
171 no warnings; # temporary; there seems to be a scoping bug, as this does not
172              # work when placed in the blocks below
173
174 # Test that deleting stash elements containing
175 # subpackages also invalidates the isa cache.
176 # Maybe this does not belong in package_aliases.t, but it is closely
177 # related to the tests immediately preceding.
178 {
179  @Pet::ISA = ("Cur", "Hound");
180  @Cur::ISA = "Hylactete";
181
182  sub Hylactete::speak { "Arff!" }
183  sub Hound::speak { "Woof!" }
184
185  my $pet = bless [], "Pet";
186
187  my $life_raft = delete $::{'Cur::'};
188
189  is $pet->speak, 'Woof!',
190   'deleting a stash from its parent stash invalidates the isa caches';
191
192  undef $life_raft;
193  is $pet->speak, 'Woof!',
194   'the deleted stash is gone completely when freed';
195 }
196 # Same thing, but with nested packages
197 {
198  @Pett::ISA = ("Curr::Curr::Curr", "Hownd");
199  @Curr::Curr::Curr::ISA = "Latrator";
200
201  sub Latrator::speak { "Arff!" }
202  sub Hownd::speak { "Woof!" }
203
204  my $pet = bless [], "Pett";
205
206  my $life_raft = delete $::{'Curr::'};
207
208  is $pet->speak, 'Woof!',
209   'deleting a stash from its parent stash resets caches of substashes';
210
211  undef $life_raft;
212  is $pet->speak, 'Woof!',
213   'the deleted substash is gone completely when freed';
214 }
215
216 # [perl #77358]
217 fresh_perl_is
218    q~#!perl -w
219      @Pet::ISA = "Tike";
220      @Tike::ISA = "Barker";
221      
222      sub Barker::speak { print "Woof!\n" }
223      sub Latrator::speak { print "Bow-wow!\n" }
224      
225      my $pet = bless [], "Pet";
226      
227      $pet->speak;
228      
229      sub Dog::speak { print "Hello.\n" } # strange dog!
230      @Dog::ISA = 'Latrator';
231      *Tike:: = delete $::{'Dog::'};
232      
233      $pet->speak;
234    ~,
235   "Woof!\nHello.\n",
236    { stderr => 1 },
237   "Assigning a nameless package over one w/subclasses updates isa caches";
238
239 # mro_package_moved needs to make a distinction between replaced and
240 # assigned stashes when keeping track of what it has seen so far.
241 no warnings; {
242     no strict 'refs';
243
244     sub bar::blonk::blonk::phoo { "bbb" }
245     sub veclum::phoo { "lasrevinu" }
246     @feedlebomp::ISA = qw 'phoo::blonk::blonk veclum';
247     *phoo::baz:: = *bar::blonk::;   # now bar::blonk:: is on both sides
248     *phoo:: = *bar::;         # here bar::blonk:: is both deleted and added
249     *bar:: = *boo::;          # now it is only known as phoo::blonk::
250
251     # At this point, before the bug was fixed, %phoo::blonk::blonk:: ended
252     # up with no effective name, allowing it to be deleted without updating
253     # its subclasses’ caches.
254
255     my $accum = '';
256
257     $accum .= 'feedlebomp'->phoo;          # bbb
258     delete ${"phoo::blonk::"}{"blonk::"};
259     $accum .= 'feedlebomp'->phoo;          # bbb (Oops!)
260     @feedlebomp::ISA = @feedlebomp::ISA;
261     $accum .= 'feedlebomp'->phoo;          # lasrevinu
262
263     is $accum, 'bbblasrevinulasrevinu',
264       'nested classes deleted & added simultaneously';
265 }
266 use warnings;
267
268 # mro_package_moved needs to check for self-referential packages.
269 # This broke Text::Template [perl #78362].
270 watchdog 3;
271 *foo:: = \%::;
272 *Acme::META::Acme:: = \*Acme::; # indirect self-reference
273 pass("mro_package_moved and self-referential packages");