deprecate: expand the documentation
[perl.git] / t / op / stash.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require "./test.pl";
6     set_up_inc( qw(../lib) );
7 }
8
9 plan( tests => 55 );
10
11 # Used to segfault (bug #15479)
12 fresh_perl_like(
13     'delete $::{STDERR}; my %a = ""',
14     qr/Odd number of elements in hash assignment at - line 1\./,
15     { switches => [ '-w' ] },
16     'delete $::{STDERR} and print a warning',
17 );
18
19 # Used to segfault
20 fresh_perl_is(
21     'BEGIN { $::{"X::"} = 2 }',
22     '',
23     { switches => [ '-w' ] },
24     q(Insert a non-GV in a stash, under warnings 'once'),
25 );
26
27 # Used to segfault, too
28 SKIP: {
29  skip_if_miniperl('requires XS');
30   fresh_perl_like(
31     'sub foo::bar{}; $mro::{get_mro}=*foo::bar; undef %foo::; require mro',
32      qr/^Subroutine mro::get_mro redefined at /,
33     { switches => [ '-w' ] },
34     q(Defining an XSUB over an existing sub with no stash under warnings),
35   );
36 }
37
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(
44                   'package A::B; sub a { // }; %A::=""',
45                   '',
46                   {},
47                   );
48     # Variant of the above which creates an object that persists until global
49     # destruction, and triggers an assertion failure prior to change
50     # a420522db95b7762
51     fresh_perl_is(
52                   'use Exporter; package A; sub a { // }; delete $::{$_} for keys %::',
53                   '',
54                   {},
55                   );
56 }
57
58 # now tests with strictures
59
60 {
61     use strict;
62     ok( !exists $pig::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) );
63 }
64
65 SKIP: {
66     eval { require B; 1 } or skip "no B", 29;
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
78     object_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
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
90     object_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
91     is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
92     is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
93     is( eval { $gv->STASH->NAME }, "two", "...but leaves stash intact");
94
95     $sub = do {
96         package three;
97         \&{"three"};
98     };
99     undef %three::;
100     $gv = b($sub)->GV;
101
102     object_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
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
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 };
117     is($st, q/four/, "...but leaves the stash intact");
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");
131     }
132
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
146     # CvSTASH should be null on a named sub if the stash has been deleted
147     {
148         package FOO;
149         sub foo {}
150         my $rfoo = \&foo;
151         package main;
152         delete $::{'FOO::'};
153         my $cv = B::svref_2object($rfoo);
154         # (is there a better way of testing for NULL ?)
155         my $stash = $cv->STASH;
156         like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub");
157     }
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{CODE}]; # not \&named; we want a real GV
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     }
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     }
227 }
228
229 # [perl #58530]
230 fresh_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
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 }
246
247
248 # Stashes that are effectively renamed
249 {
250     package rile;
251
252     use Config;
253
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",
263      'ref() returns the same thing when an object\'s stash is moved';
264     ::like "$obj", qr "^rile=ARRAY\(0x[\da-f]+\)\z",
265      'objects stringify the same way when their stashes are moved';
266     ::is eval '__PACKAGE__', 'rile',
267          '__PACKAGE__ returns the same when the current stash is moved';
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",
277      'ref() returns the same thing when an object\'s stash is detached';
278     ::like "$obj", qr "^rile=ARRAY\(0x[\da-f]+\)\z",
279      'objects stringify the same way when their stashes are detached';
280     ::is eval '__PACKAGE__', 'rile',
281          '__PACKAGE__ returns the same when the current stash is detached';
282 }
283
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 }
294
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 }
303
304 # [perl #88138] ' not equivalent to :: before a null
305 ${"a'\0b"} = "c";
306 is ${"a::\0b"}, "c", "' is equivalent to :: before a null";
307
308 # [perl #101486] Clobbering the current package
309 ok eval '
310      package Do;
311      BEGIN { *Do:: = *Re:: }
312      sub foo{};
313      1
314   ', 'no crashing or errors when clobbering the current package';
315
316 # Bareword lookup should not vivify stashes
317 is 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';
324
325 is 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';
331
332 is 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';
338
339 is runperl(
340     prog => 'BEGIN { %: = 0; $^W=1}; print qq|ok\n|',
341     stderr => 1,
342    ),
343    "ok\n",
344    "[perl #128238] don't treat %: as a stash (needs 2 colons)";
345
346 is 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";
352
353 is runperl(
354     prog => '%:: = (); print *{q|::|}, qq|\n|',
355     stderr => 1,
356    ),
357    "*main::main::\n",
358    "[perl #129869] lookup %:: by name after clearing %::";