This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
f2e552359ce9a91c18697fef49fc07eb79b679bf
[perl5.git] / t / op / stash.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = qw(../lib);
6 }
7
8 BEGIN { require "./test.pl"; }
9
10 plan( tests => 58 );
11
12 # Used to segfault (bug #15479)
13 fresh_perl_like(
14     'delete $::{STDERR}; my %a = ""',
15     qr/Odd number of elements in hash assignment at - line 1\./,
16     { switches => [ '-w' ] },
17     'delete $::{STDERR} and print a warning',
18 );
19
20 # Used to segfault
21 fresh_perl_is(
22     'BEGIN { $::{"X::"} = 2 }',
23     '',
24     { switches => [ '-w' ] },
25     q(Insert a non-GV in a stash, under warnings 'once'),
26 );
27
28 # Used to segfault, too
29 SKIP: {
30  skip_if_miniperl('requires XS');
31   fresh_perl_like(
32     'sub foo::bar{}; $mro::{get_mro}=*foo::bar; undef %foo::; require mro',
33      qr/^Subroutine mro::get_mro redefined at /,
34     { switches => [ '-w' ] },
35     q(Defining an XSUB over an existing sub with no stash under warnings),
36   );
37 }
38
39 {
40     no warnings 'deprecated';
41     ok( defined %oedipa::maas::, q(stashes happen to be defined if not used) );
42     ok( defined %{"oedipa::maas::"}, q(- work with hard refs too) );
43
44     ok( defined %tyrone::slothrop::, q(stashes are defined if seen at compile time) );
45     ok( defined %{"tyrone::slothrop::"}, q(- work with hard refs too) );
46
47     ok( defined %bongo::shaftsbury::, q(stashes are defined if a var is seen at compile time) );
48     ok( defined %{"bongo::shaftsbury::"}, q(- work with hard refs too) );
49 }
50
51 package tyrone::slothrop;
52 $bongo::shaftsbury::scalar = 1;
53
54 package main;
55
56 # Used to warn
57 # Unbalanced string table refcount: (1) for "A::" during global destruction.
58 # for ithreads.
59 {
60     local $ENV{PERL_DESTRUCT_LEVEL} = 2;
61     fresh_perl_is(
62                   'package A::B; sub a { // }; %A::=""',
63                   '',
64                   {},
65                   );
66     # Variant of the above which creates an object that persists until global
67     # destruction, and triggers an assertion failure prior to change
68     # a420522db95b7762
69     fresh_perl_is(
70                   'use Exporter; package A; sub a { // }; delete $::{$_} for keys %::',
71                   '',
72                   {},
73                   );
74 }
75
76 # now tests in eval
77
78 ok( eval  { no warnings 'deprecated'; defined %achtfaden:: },   'works in eval{}' );
79 ok( eval q{ no warnings 'deprecated'; defined %schoenmaker:: }, 'works in eval("")' );
80
81 # now tests with strictures
82
83 {
84     use strict;
85     no warnings 'deprecated';
86     ok( defined %pig::, q(referencing a non-existent stash doesn't produce stricture errors) );
87     ok( !exists $pig::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) );
88 }
89
90 SKIP: {
91     eval { require B; 1 } or skip "no B", 29;
92
93     *b = \&B::svref_2object;
94     my $CVf_ANON = B::CVf_ANON();
95
96     my $sub = do {
97         package one;
98         \&{"one"};
99     };
100     delete $one::{one};
101     my $gv = b($sub)->GV;
102
103     object_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
104     is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
105     is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
106     is( eval { $gv->STASH->NAME }, "one", "...but leaves stash intact");
107
108     $sub = do {
109         package two;
110         \&{"two"};
111     };
112     %two:: = ();
113     $gv = b($sub)->GV;
114
115     object_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
116     is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
117     is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
118     is( eval { $gv->STASH->NAME }, "two", "...but leaves stash intact");
119
120     $sub = do {
121         package three;
122         \&{"three"};
123     };
124     undef %three::;
125     $gv = b($sub)->GV;
126
127     object_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
128     is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
129     is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
130     is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash");
131
132     my $sub = do {
133         package four;
134         sub { 1 };
135     };
136     %four:: = ();
137
138     my $gv = B::svref_2object($sub)->GV;
139     ok($gv->isa(q/B::GV/), "cleared stash leaves anon CV with valid GV");
140
141     my $st = eval { $gv->STASH->NAME };
142     is($st, q/four/, "...but leaves the stash intact");
143
144     my $sub = do {
145         package five;
146         sub { 1 };
147     };
148     undef %five::;
149
150     $gv = B::svref_2object($sub)->GV;
151     ok($gv->isa(q/B::GV/), "undefed stash leaves anon CV with valid GV");
152
153     $st = eval { $gv->STASH->NAME };
154     { local $TODO = 'STASHES not anonymized';
155         is($st, q/__ANON__/, "...and an __ANON__ stash");
156     }
157
158     my $sub = do {
159         package six;
160         \&{"six"}
161     };
162     my $stash_glob = delete $::{"six::"};
163     # Now free the GV while the stash still exists (though detached)
164     delete $$stash_glob{"six"};
165     $gv = B::svref_2object($sub)->GV;
166     ok($gv->isa(q/B::GV/),
167        'anonymised CV whose stash is detached still has a GV');
168     is $gv->STASH->NAME, '__ANON__',
169      'CV anonymised when its stash is detached becomes __ANON__::__ANON__';
170
171     # CvSTASH should be null on a named sub if the stash has been deleted
172     {
173         package FOO;
174         sub foo {}
175         my $rfoo = \&foo;
176         package main;
177         delete $::{'FOO::'};
178         my $cv = B::svref_2object($rfoo);
179         # (is there a better way of testing for NULL ?)
180         my $stash = $cv->STASH;
181         like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub");
182     }
183
184     # on glob reassignment, orphaned CV should have anon CvGV
185
186     {
187         my $r;
188         eval q[
189             package FOO2;
190             sub f{};
191             $r = \&f;
192             *f = sub {};
193         ];
194         delete $FOO2::{f};
195         my $cv = B::svref_2object($r);
196         my $gv = $cv->GV;
197         ok($gv->isa(q/B::GV/), "orphaned CV has valid GV");
198         is($gv->NAME, '__ANON__', "orphaned CV has anon GV");
199     }
200
201     # deleting __ANON__ glob shouldn't break things
202
203     {
204         package FOO3;
205         sub named {};
206         my $anon = sub {};
207         my $named = eval q[\&named];
208         package main;
209         delete $FOO3::{named}; # make named anonymous
210
211         delete $FOO3::{__ANON__}; # whoops!
212         my ($cv,$gv);
213         $cv = B::svref_2object($named);
214         $gv = $cv->GV;
215         ok($gv->isa(q/B::GV/), "ex-named CV has valid GV");
216         is($gv->NAME, '__ANON__', "ex-named CV has anon GV");
217
218         $cv = B::svref_2object($anon);
219         $gv = $cv->GV;
220         ok($gv->isa(q/B::GV/), "anon CV has valid GV");
221         is($gv->NAME, '__ANON__', "anon CV has anon GV");
222     }
223
224     {
225         my $r;
226         {
227             package bloop;
228
229             BEGIN {
230                 $r = \&main::whack;
231             }
232         }
233
234         my $br = B::svref_2object($r);
235         is ($br->STASH->NAME, 'bloop',
236             'stub records the package it was compiled in');
237         # Arguably this shouldn't quite be here, but it's easy to add it
238         # here, and tricky to figure out a different good place for it.
239         like ($br->FILE, qr/stash/i,
240               'stub records the file it was compiled in');
241
242         # We need to take this reference "late", after the subroutine is
243         # defined.
244         $br = B::svref_2object(eval 'sub whack {}; \&whack');
245         die $@ if $@;
246
247         is ($br->STASH->NAME, 'main',
248             'definition overrides the package it was compiled in');
249         like ($br->FILE, qr/eval/,
250               'definition overrides the file it was compiled in');
251     }
252 }
253
254 # [perl #58530]
255 fresh_perl_is(
256     'sub foo { 1 }; use overload q/""/ => \&foo;' .
257         'delete $main::{foo}; bless []',
258     "",
259     {},
260     "no segfault with overload/deleted stash entry [#58530]",
261 );
262
263 # make sure having a sub called __ANON__ doesn't confuse perl.
264
265 {
266     my $c;
267     sub __ANON__ { $c = (caller(0))[3]; }
268     __ANON__();
269     is ($c, 'main::__ANON__', '__ANON__ sub called ok');
270 }
271
272
273 # Stashes that are effectively renamed
274 {
275     package rile;
276
277     use Config;
278
279     my $obj  = bless [];
280     my $globref = \*tat;
281
282     # effectively rename a stash
283     *slin:: = *rile::; *rile:: = *zor::;
284     
285     ::is *$globref, "*rile::tat",
286      'globs stringify the same way when stashes are moved';
287     ::is ref $obj, "rile",
288      'ref() returns the same thing when an object’s stash is moved';
289     ::like "$obj", qr "^rile=ARRAY\(0x[\da-f]+\)\z",
290      'objects stringify the same way when their stashes are moved';
291     ::is eval '__PACKAGE__', 'rile',
292          '__PACKAGE__ returns the same when the current stash is moved';
293
294     # Now detach it completely from the symtab, making it effect-
295     # ively anonymous
296     my $life_raft = \%slin::;
297     *slin:: = *zor::;
298
299     ::is *$globref, "*rile::tat",
300      'globs stringify the same way when stashes are detached';
301     ::is ref $obj, "rile",
302      'ref() returns the same thing when an object’s stash is detached';
303     ::like "$obj", qr "^rile=ARRAY\(0x[\da-f]+\)\z",
304      'objects stringify the same way when their stashes are detached';
305     ::is eval '__PACKAGE__', 'rile',
306          '__PACKAGE__ returns the same when the current stash is detached';
307 }
308
309 # Setting the name during undef %stash:: should have no effect.
310 {
311     my $glob = \*Phoo::glob;
312     sub o::DESTROY { eval '++$Phoo::bar' }
313     no strict 'refs';
314     ${"Phoo::thing1"} = bless [], "o";
315     undef %Phoo::;
316     is "$$glob", "*__ANON__::glob",
317       "setting stash name during undef has no effect";
318 }
319
320 # [perl #88134] incorrect package structure
321 {
322     package Bear::;
323     sub baz{1}
324     package main;
325     ok eval { Bear::::baz() },
326      'packages ending with :: are self-consistent';
327 }
328
329 # [perl #88138] ' not equivalent to :: before a null
330 ${"a'\0b"} = "c";
331 is ${"a::\0b"}, "c", "' is equivalent to :: before a null";
332
333 # [perl #101486] Clobbering the current package
334 ok eval '
335      package Do;
336      BEGIN { *Do:: = *Re:: }
337      sub foo{};
338      1
339   ', 'no crashing or errors when clobbering the current package';