This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add CVf_CVGV_RC flag
[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
cfc1e951 10plan( tests => 38 );
6b78add2
RGS
11
12# Used to segfault (bug #15479)
d963bf01 13fresh_perl_like(
6b78add2 14 '%:: = ""',
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
d47e1c27
NC
28{
29 no warnings 'deprecated';
0cc522c3
NC
30 ok( defined %oedipa::maas::, q(stashes happen to be defined if not used) );
31 ok( defined %{"oedipa::maas::"}, q(- work with hard refs too) );
adc51b97 32
d47e1c27
NC
33 ok( defined %tyrone::slothrop::, q(stashes are defined if seen at compile time) );
34 ok( defined %{"tyrone::slothrop::"}, q(- work with hard refs too) );
adc51b97 35
d47e1c27
NC
36 ok( defined %bongo::shaftsbury::, q(stashes are defined if a var is seen at compile time) );
37 ok( defined %{"bongo::shaftsbury::"}, q(- work with hard refs too) );
38}
adc51b97
RGS
39
40package tyrone::slothrop;
41$bongo::shaftsbury::scalar = 1;
aec56d99
NC
42
43package main;
44
45# Used to warn
46# Unbalanced string table refcount: (1) for "A::" during global destruction.
47# for ithreads.
48{
49 local $ENV{PERL_DESTRUCT_LEVEL} = 2;
50 fresh_perl_is(
51 'package A; sub a { // }; %::=""',
52 '',
53 '',
54 );
55}
ce10b5d1 56
d6069db2
RGS
57# now tests in eval
58
0cc522c3
NC
59ok( eval { no warnings 'deprecated'; defined %achtfaden:: }, 'works in eval{}' );
60ok( eval q{ no warnings 'deprecated'; defined %schoenmaker:: }, 'works in eval("")' );
d6069db2 61
ce10b5d1
RGS
62# now tests with strictures
63
d018fae5
BM
64{
65 use strict;
d47e1c27 66 no warnings 'deprecated';
0cc522c3 67 ok( defined %pig::, q(referencing a non-existent stash doesn't produce stricture errors) );
d018fae5
BM
68 ok( !exists $pig::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) );
69}
70
71SKIP: {
fb6e4a4e 72 eval { require B; 1 } or skip "no B", 18;
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
84 isa_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
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
96 isa_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
97 is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
98 is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
99 is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash");
100
101 $sub = do {
102 package three;
103 \&{"three"};
104 };
105 undef %three::;
106 $gv = b($sub)->GV;
107
108 isa_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
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 };
123 { local $TODO = 'STASHES not anonymized';
124 is($st, q/__ANON__/, "...and an __ANON__ stash");
125 }
126
127 my $sub = do {
128 package five;
129 sub { 1 };
130 };
131 undef %five::;
132
133 $gv = B::svref_2object($sub)->GV;
134 ok($gv->isa(q/B::GV/), "undefed stash leaves anon CV with valid GV");
135
136 $st = eval { $gv->STASH->NAME };
137 { local $TODO = 'STASHES not anonymized';
138 is($st, q/__ANON__/, "...and an __ANON__ stash");
d018fae5 139 }
803f2748 140
d018fae5
BM
141 # [perl #58530]
142 fresh_perl_is(
143 'sub foo { 1 }; use overload q/""/ => \&foo;' .
144 'delete $main::{foo}; bless []',
145 "",
146 {},
147 "no segfault with overload/deleted stash entry [#58530]",
148 );
4c74a7df 149
803f2748 150 # CvSTASH should be null on a named sub if the stash has been deleted
4c74a7df
DM
151 {
152 package FOO;
153 sub foo {}
154 my $rfoo = \&foo;
155 package main;
156 delete $::{'FOO::'};
157 my $cv = B::svref_2object($rfoo);
803f2748 158 # (is there a better way of testing for NULL ?)
4c74a7df
DM
159 my $stash = $cv->STASH;
160 like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub");
161 }
803f2748
DM
162
163 # on glob reassignment, orphaned CV should have anon CvGV
164
165 {
166 my $r;
167 eval q[
168 package FOO2;
169 sub f{};
170 $r = \&f;
171 *f = sub {};
172 ];
173 delete $FOO2::{f};
174 my $cv = B::svref_2object($r);
175 my $gv = $cv->GV;
176 ok($gv->isa(q/B::GV/), "orphaned CV has valid GV");
177 is($gv->NAME, '__ANON__', "orphaned CV has anon GV");
178 }
179
180 # deleting __ANON__ glob shouldn't break things
181
182 {
183 package FOO3;
184 sub named {};
185 my $anon = sub {};
186 my $named = eval q[\&named];
187 package main;
188 delete $FOO3::{named}; # make named anonymous
189
190 delete $FOO3::{__ANON__}; # whoops!
191 my ($cv,$gv);
192 $cv = B::svref_2object($named);
193 $gv = $cv->GV;
194 ok($gv->isa(q/B::GV/), "ex-named CV has valid GV");
195 is($gv->NAME, '__ANON__', "ex-named CV has anon GV");
196
197 $cv = B::svref_2object($anon);
198 $gv = $cv->GV;
199 ok($gv->isa(q/B::GV/), "anon CV has valid GV");
200 is($gv->NAME, '__ANON__', "anon CV has anon GV");
201 }
d018fae5 202}
cfc1e951
DM
203
204# make sure having a sub called __ANON__ doesn't confuse perl.
205
206{
207 my $c;
208 sub __ANON__ { $c = (caller(0))[3]; }
209 __ANON__();
210 is ($c, 'main::__ANON__', '__ANON__ sub called ok');
211}