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