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