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
25BEGIN { chdir 't' if -d 't'; require './test.pl' }
26plan 22;
27
28sub foo {
29    my ($block) = @_;
30
31    my $got;
32    $_ = $got ? "this is clearly a bug" : "ok";
33
34    $got = 1;
35
36    $block->();
37}
38sub Foo::DESTROY {
39    foo(sub { });
40    return;
41}
42
43eval { foo(sub { my $o = bless {}, 'Foo'; die }) };
44is $_, "ok", 'die triggering DESTROY that calls outer sub';
45
46undef $_;
47{ foo(sub { my $o = bless {}, 'Foo'; last }) }
48is $_, "ok", 'last triggering DESTROY that calls outer sub';
49
50undef $_;
51{ foo(sub { my $o = bless {}, 'Foo'; next }) }
52is $_, "ok", 'next triggering DESTROY that calls outer sub';
53
54undef $_;
55{ if (!$count++) { foo(sub { my $o = bless {}, 'Foo'; redo }) } }
56is $_, "ok", 'redo triggering DESTROY that calls outer sub';
57
58undef $_;
59foo(sub { my $o = bless {}, 'Foo'; goto test });
60test:
61is $_, "ok", 'goto triggering DESTROY that calls outer sub';
62
63# END blocks trigger in reverse
64sub END { is $_, "ok", 'exit triggering DESTROY that calls outer sub' }
65sub END { undef $_; foo(sub { my $o = bless {}, 'Foo'; exit }); }
66
67
68sub 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}
82sub Bar::DESTROY {
83    bar();
84    return;
85}
86
87eval { bar(sub { die }) };
88is $_, "ok", 'die triggering DESTROY that calls current sub';
89
90undef $_;
91{ bar(sub { last }) }
92is $_, "ok", 'last triggering DESTROY that calls current sub';
93
94undef $_;
95{ bar(sub { next }) }
96is $_, "ok", 'next triggering DESTROY that calls current sub';
97
98undef $_;
99undef $count;
100{ if (!$count++) { bar(sub { redo }) } }
101is $_, "ok", 'redo triggering DESTROY that calls current sub';
102
103undef $_;
104bar(sub { goto test2 });
105test2:
106is $_, "ok", 'goto triggering DESTROY that calls current sub';
107
108sub END { is $_, "ok", 'exit triggering DESTROY that calls current sub' }
109sub END { undef $_; bar(sub { exit }) }
110
111
112format 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.
127sub Foomat::DESTROY {
128    local $inner_format;
129    local $~ = "foo";
130    write;
131    return;
132}
133
134$~ = "foo";
135
136format inner_die =
137@
138{ my $o = bless {}, 'Foomat'; die }
139.
140undef $_;
141study;
142eval { local $inner_format = 'inner_die'; write };
143is $_, "ok", 'die triggering DESTROY that calls outer format';
144
145format inner_last =
146@
147{ my $o = bless {}, 'Foomat'; last LAST }
148.
149undef $_;
150LAST: { local $inner_format = 'inner_last'; write }
151is $_, "ok", 'last triggering DESTROY that calls outer format';
152
153format inner_next =
154@
155{ my $o = bless {}, 'Foomat'; next NEXT }
156.
157undef $_;
158NEXT: { local $inner_format = 'inner_next'; write }
159is $_, "ok", 'next triggering DESTROY that calls outer format';
160
161format inner_redo =
162@
163{ my $o = bless {}, 'Foomat'; redo REDO }
164.
165undef $_;
166undef $_;
167undef $count;
168REDO: { if (!$count++) { local $inner_format = 'inner_redo'; write } }
169is $_, "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
181format inner_exit =
182@
183{ my $o = bless {}, 'Foomat'; exit }
184.
185# END blocks trigger in reverse
186END { is $_, "ok", 'exit triggering DESTROY that calls outer format' }
187END { local $inner_format = 'inner_exit'; write }
188
189
190format 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.
206sub Barmat::DESTROY {
207    local $block;
208    write;
209    return;
210}
211
212$~ = "bar";
213
214undef $_;
215eval { local $block = sub { die }; write };
216is $_, "ok", 'die triggering DESTROY directly inside format';
217
218undef $_;
219LAST: { local $block = sub { last LAST }; write }
220is $_, "ok", 'last triggering DESTROY directly inside format';
221
222undef $_;
223NEXT: { local $block = sub { next NEXT }; write }
224is $_, "ok", 'next triggering DESTROY directly inside format';
225
226undef $_;
227undef $count;
228REDO: { if (!$count++) { local $block = sub { redo REDO }; write } }
229is $_, "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
236sub END { is $_, "ok", 'exit triggering DESTROY directly inside format' }
237sub END { undef $_; local $block = sub { exit }; write }
238