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