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
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 => 38 );
11
12 # Used to segfault (bug #15479)
13 fresh_perl_like(
14     '%:: = ""',
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 {
29     no warnings 'deprecated';
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) );
32
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) );
35
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 }
39
40 package tyrone::slothrop;
41 $bongo::shaftsbury::scalar = 1;
42
43 package 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 }
56
57 # now tests in eval
58
59 ok( eval  { no warnings 'deprecated'; defined %achtfaden:: },   'works in eval{}' );
60 ok( eval q{ no warnings 'deprecated'; defined %schoenmaker:: }, 'works in eval("")' );
61
62 # now tests with strictures
63
64 {
65     use strict;
66     no warnings 'deprecated';
67     ok( defined %pig::, q(referencing a non-existent stash doesn't produce stricture errors) );
68     ok( !exists $pig::{bodine}, q(referencing a non-existent stash element doesn't produce stricture errors) );
69 }
70
71 SKIP: {
72     eval { require B; 1 } or skip "no B", 18;
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
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");
139     }
140
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     );
149
150     # CvSTASH should be null on a named sub if the stash has been deleted
151     {
152         package FOO;
153         sub foo {}
154         my $rfoo = \&foo;
155         package main;
156         delete $::{'FOO::'};
157         my $cv = B::svref_2object($rfoo);
158         # (is there a better way of testing for NULL ?)
159         my $stash = $cv->STASH;
160         like($stash, qr/B::SPECIAL/, "NULL CvSTASH on named sub");
161     }
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     }
202 }
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 }