3 # Complicated enough to get its own test file.
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.
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
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.
25 BEGIN { chdir 't'; require './test.pl' }
32 $_ = $got ? "this is clearly a bug" : "ok";
43 eval { foo(sub { my $o = bless {}, 'Foo'; die }) };
44 is $_, "ok", 'die triggering DESTROY that calls outer sub';
47 { foo(sub { my $o = bless {}, 'Foo'; last }) }
48 is $_, "ok", 'last triggering DESTROY that calls outer sub';
51 { foo(sub { my $o = bless {}, 'Foo'; next }) }
52 is $_, "ok", 'next triggering DESTROY that calls outer sub';
55 { if (!$count++) { foo(sub { my $o = bless {}, 'Foo'; redo }) } }
56 is $_, "ok", 'redo triggering DESTROY that calls outer sub';
59 foo(sub { my $o = bless {}, 'Foo'; goto test });
61 is $_, "ok", 'goto triggering DESTROY that calls outer sub';
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 }); }
72 $_ = $got ? "this is clearly a bug" : "ok";
87 eval { bar(sub { die }) };
88 is $_, "ok", 'die triggering DESTROY that calls current sub';
92 is $_, "ok", 'last triggering DESTROY that calls current sub';
96 is $_, "ok", 'next triggering DESTROY that calls current sub';
100 { if (!$count++) { bar(sub { redo }) } }
101 is $_, "ok", 'redo triggering DESTROY that calls current sub';
104 bar(sub { goto test2 });
106 is $_, "ok", 'goto triggering DESTROY that calls current sub';
108 sub END { is $_, "ok", 'exit triggering DESTROY that calls current sub' }
109 sub END { undef $_; bar(sub { exit }) }
116 $_ = $got ? "this is clearly a bug" : "ok";
121 local $~ = $inner_format;
127 sub Foomat::DESTROY {
138 { my $o = bless {}, 'Foomat'; die }
142 eval { local $inner_format = 'inner_die'; write };
143 is $_, "ok", 'die triggering DESTROY that calls outer format';
147 { my $o = bless {}, 'Foomat'; last LAST }
150 LAST: { local $inner_format = 'inner_last'; write }
151 is $_, "ok", 'last triggering DESTROY that calls outer format';
155 { my $o = bless {}, 'Foomat'; next NEXT }
158 NEXT: { local $inner_format = 'inner_next'; write }
159 is $_, "ok", 'next triggering DESTROY that calls outer format';
163 { my $o = bless {}, 'Foomat'; redo REDO }
168 REDO: { if (!$count++) { local $inner_format = 'inner_redo'; write } }
169 is $_, "ok", 'redo triggering DESTROY that calls outer format';
171 # Can't "goto" out of a pseudo block.... (another bug?)
174 #{ my $o = bless {}, 'Foomat'; goto test3 }
177 #{ local $inner_format = 'inner_goto'; write }
179 #is $_, "ok", 'goto triggering DESTROY that calls outer format';
183 { my $o = bless {}, 'Foomat'; exit }
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 }
194 $_ = $got ? "this is clearly a bug" : "ok";
200 $o = bless {}, "Barmat";
206 sub Barmat::DESTROY {
215 eval { local $block = sub { die }; write };
216 is $_, "ok", 'die triggering DESTROY directly inside format';
219 LAST: { local $block = sub { last LAST }; write }
220 is $_, "ok", 'last triggering DESTROY directly inside format';
223 NEXT: { local $block = sub { next NEXT }; write }
224 is $_, "ok", 'next triggering DESTROY directly inside format';
228 REDO: { if (!$count++) { local $block = sub { redo REDO }; write } }
229 is $_, "ok", 'redo triggering DESTROY directly inside format';
232 #{ local $block = sub { goto test4 }; write }
234 #is $_, "ok", 'goto triggering DESTROY directly inside format';
236 sub END { is $_, "ok", 'exit triggering DESTROY directly inside format' }
237 sub END { undef $_; local $block = sub { exit }; write }