This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove the tokeniser hack that prevents compile-time vivification of %stash::
[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 => 31 );
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     TODO: {
114         local $TODO = "anon CVs not accounted for yet";
115
116         my @results = split "\n", runperl(
117             switches    => [ "-MB", "-l" ],
118             prog        => q{
119                 my $sub = do {
120                     package four;
121                     sub { 1 };
122                 };
123                 %four:: = ();
124
125                 my $gv = B::svref_2object($sub)->GV;
126                 print $gv->isa(q/B::GV/) ? q/ok/ : q/not ok/;
127
128                 my $st = eval { $gv->STASH->NAME };
129                 print $st eq q/__ANON__/ ? q/ok/ : q/not ok/;
130
131                 my $sub = do {
132                     package five;
133                     sub { 1 };
134                 };
135                 undef %five::;
136
137                 $gv = B::svref_2object($sub)->GV;
138                 print $gv->isa(q/B::GV/) ? q/ok/ : q/not ok/;
139
140                 $st = eval { $gv->STASH->NAME };
141                 print $st eq q/__ANON__/ ? q/ok/ : q/not ok/;
142
143                 print q/done/;
144             },
145             ($^O eq 'VMS') ? (stderr => 1) : ()
146         );
147
148         ok( @results == 5 && $results[4] eq "done",
149             "anon CVs in undefed stash don't segfault" )
150             or todo_skip $TODO, 4;
151
152         ok( $results[0] eq "ok", 
153             "cleared stash leaves anon CV with valid GV");
154         ok( $results[1] eq "ok",
155             "...and an __ANON__ stash");
156             
157         ok( $results[2] eq "ok", 
158             "undefed stash leaves anon CV with valid GV");
159         ok( $results[3] eq "ok",
160             "...and an __ANON__ stash");
161     }
162     
163     # [perl #58530]
164     fresh_perl_is(
165         'sub foo { 1 }; use overload q/""/ => \&foo;' .
166             'delete $main::{foo}; bless []',
167         "",
168         {},
169         "no segfault with overload/deleted stash entry [#58530]",
170     );
171 }