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 }