Perl_op_sibling_splice(0 remove dead code
[perl.git] / t / op / rt119311.t
1 #!perl
2
3 # Complicated enough to get its own test file.
4
5 # When a subroutine is called recursively, it gets a new pad indexed by its
6 # recursion depth (CvDEPTH).  If the sub is called at the same recursion
7 # depth again, the pad is reused.  Pad entries are localised on the
8 # savestack when ‘my’ is encountered.
9 #
10 # When a die/last/goto/exit unwinds the stack, it can trigger a DESTROY
11 # that recursively calls a subroutine that is in the middle of being
12 # popped.  Before this bug was fixed, the context stack was popped first,
13 # including CvDEPTH--, and then the savestack would be popped afterwards.
14 # Popping the savestack could trigger DESTROY and cause a sub to be called
15 # after its CvDEPTH was lowered but while its pad entries were still live
16 # and waiting to be cleared.  Decrementing CvDEPTH marks the pad as being
17 # available for the next call, which is wrong if the pad entries have not
18 # been cleared.
19 #
20 # Below we test two main variations of the bug that results.  First, we
21 # test an inner sub’s lexical holding an object whose DESTROY calls the
22 # outer sub.  Then we test a lexical directly inside the sub that DESTROY
23 # calls.  Then we repeat with formats.
24
25 BEGIN { chdir 't' if -d 't'; require './test.pl' }
26 plan 22;
27
28 sub foo {
29     my ($block) = @_;
30
31     my $got;
32     $_ = $got ? "this is clearly a bug" : "ok";
33
34     $got = 1;
35
36     $block->();
37 }
38 sub Foo::DESTROY {
39     foo(sub { });
40     return;
41 }
42
43 eval { foo(sub { my $o = bless {}, 'Foo'; die }) };
44 is $_, "ok", 'die triggering DESTROY that calls outer sub';
45
46 undef $_;
47 { foo(sub { my $o = bless {}, 'Foo'; last }) }
48 is $_, "ok", 'last triggering DESTROY that calls outer sub';
49
50 undef $_;
51 { foo(sub { my $o = bless {}, 'Foo'; next }) }
52 is $_, "ok", 'next triggering DESTROY that calls outer sub';
53
54 undef $_;
55 { if (!$count++) { foo(sub { my $o = bless {}, 'Foo'; redo }) } }
56 is $_, "ok", 'redo triggering DESTROY that calls outer sub';
57
58 undef $_;
59 foo(sub { my $o = bless {}, 'Foo'; goto test });
60 test:
61 is $_, "ok", 'goto triggering DESTROY that calls outer sub';
62
63 # END blocks trigger in reverse
64 sub END { is $_, "ok", 'exit triggering DESTROY that calls outer sub' }
65 sub END { undef $_; foo(sub { my $o = bless {}, 'Foo'; exit }); }
66
67
68 sub bar {
69     my ($block) = @_;
70
71     my $got;
72     $_ = $got ? "this is clearly a bug" : "ok";
73
74     $got = 1;
75
76     my $o;
77     if ($block) {
78         $o = bless {}, "Bar";
79         $block->();
80     }
81 }
82 sub Bar::DESTROY {
83     bar();
84     return;
85 }
86
87 eval { bar(sub { die }) };
88 is $_, "ok", 'die triggering DESTROY that calls current sub';
89
90 undef $_;
91 { bar(sub { last }) }
92 is $_, "ok", 'last triggering DESTROY that calls current sub';
93
94 undef $_;
95 { bar(sub { next }) }
96 is $_, "ok", 'next triggering DESTROY that calls current sub';
97
98 undef $_;
99 undef $count;
100 { if (!$count++) { bar(sub { redo }) } }
101 is $_, "ok", 'redo triggering DESTROY that calls current sub';
102
103 undef $_;
104 bar(sub { goto test2 });
105 test2:
106 is $_, "ok", 'goto triggering DESTROY that calls current sub';
107
108 sub END { is $_, "ok", 'exit triggering DESTROY that calls current sub' }
109 sub END { undef $_; bar(sub { exit }) }
110
111
112 format foo =
113 @
114 {
115     my $got;
116     $_ = $got ? "this is clearly a bug" : "ok";
117
118     $got = 1;
119
120     if ($inner_format) {
121         local $~ = $inner_format;
122         write;
123     }
124     "#"
125 }
126 .
127 sub Foomat::DESTROY {
128     local $inner_format;
129     local $~ = "foo";
130     write;
131     return;
132 }
133
134 $~ = "foo";
135
136 format inner_die =
137 @
138 { my $o = bless {}, 'Foomat'; die }
139 .
140 undef $_;
141 study;
142 eval { local $inner_format = 'inner_die'; write };
143 is $_, "ok", 'die triggering DESTROY that calls outer format';
144
145 format inner_last =
146 @
147 { my $o = bless {}, 'Foomat'; last LAST }
148 .
149 undef $_;
150 LAST: { local $inner_format = 'inner_last'; write }
151 is $_, "ok", 'last triggering DESTROY that calls outer format';
152
153 format inner_next =
154 @
155 { my $o = bless {}, 'Foomat'; next NEXT }
156 .
157 undef $_;
158 NEXT: { local $inner_format = 'inner_next'; write }
159 is $_, "ok", 'next triggering DESTROY that calls outer format';
160
161 format inner_redo =
162 @
163 { my $o = bless {}, 'Foomat'; redo REDO }
164 .
165 undef $_;
166 undef $_;
167 undef $count;
168 REDO: { if (!$count++) { local $inner_format = 'inner_redo'; write } }
169 is $_, "ok", 'redo triggering DESTROY that calls outer format';
170
171 # Can't "goto" out of a pseudo block.... (another bug?)
172 #format inner_goto =
173 #@
174 #{ my $o = bless {}, 'Foomat'; goto test3 }
175 #.
176 #undef $_;
177 #{ local $inner_format = 'inner_goto'; write }
178 #test3:
179 #is $_, "ok", 'goto triggering DESTROY that calls outer format';
180
181 format inner_exit =
182 @
183 { my $o = bless {}, 'Foomat'; exit }
184 .
185 # END blocks trigger in reverse
186 END { is $_, "ok", 'exit triggering DESTROY that calls outer format' }
187 END { local $inner_format = 'inner_exit'; write }
188
189
190 format bar =
191 @
192 {
193     my $got;
194     $_ = $got ? "this is clearly a bug" : "ok";
195
196     $got = 1;
197
198     my $o;
199     if ($block) {
200         $o = bless {}, "Barmat";
201         $block->();
202     }
203     "#"
204 }
205 .
206 sub Barmat::DESTROY {
207     local $block;
208     write;
209     return;
210 }
211
212 $~ = "bar";
213
214 undef $_;
215 eval { local $block = sub { die }; write };
216 is $_, "ok", 'die triggering DESTROY directly inside format';
217
218 undef $_;
219 LAST: { local $block = sub { last LAST }; write }
220 is $_, "ok", 'last triggering DESTROY directly inside format';
221
222 undef $_;
223 NEXT: { local $block = sub { next NEXT }; write }
224 is $_, "ok", 'next triggering DESTROY directly inside format';
225
226 undef $_;
227 undef $count;
228 REDO: { if (!$count++) { local $block = sub { redo REDO }; write } }
229 is $_, "ok", 'redo triggering DESTROY directly inside format';
230
231 #undef $_;
232 #{ local $block = sub { goto test4 }; write }
233 #test4:
234 #is $_, "ok", 'goto triggering DESTROY directly inside format';
235
236 sub END { is $_, "ok", 'exit triggering DESTROY directly inside format' }
237 sub END { undef $_; local $block = sub { exit }; write }