Commit | Line | Data |
---|---|---|
25375124 FC |
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 | |
0aa5e2e6 | 7 | # depth again, the pad is reused. Pad entries are localised on the |
25375124 FC |
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'; 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 } |