+#!perl
+
+# Complicated enough to get its own test file.
+
+# When a subroutine is called recursively, it gets a new pad indexed by its
+# recursion depth (CvDEPTH). If the sub is called at the same recursion
+# depth again, the pad is reused. Pad entries are localise on the
+# savestack when ‘my’ is encountered.
+#
+# When a die/last/goto/exit unwinds the stack, it can trigger a DESTROY
+# that recursively calls a subroutine that is in the middle of being
+# popped. Before this bug was fixed, the context stack was popped first,
+# including CvDEPTH--, and then the savestack would be popped afterwards.
+# Popping the savestack could trigger DESTROY and cause a sub to be called
+# after its CvDEPTH was lowered but while its pad entries were still live
+# and waiting to be cleared. Decrementing CvDEPTH marks the pad as being
+# available for the next call, which is wrong if the pad entries have not
+# been cleared.
+#
+# Below we test two main variations of the bug that results. First, we
+# test an inner sub’s lexical holding an object whose DESTROY calls the
+# outer sub. Then we test a lexical directly inside the sub that DESTROY
+# calls. Then we repeat with formats.
+
+BEGIN { chdir 't'; require './test.pl' }
+plan 22;
+
+sub foo {
+ my ($block) = @_;
+
+ my $got;
+ $_ = $got ? "this is clearly a bug" : "ok";
+
+ $got = 1;
+
+ $block->();
+}
+sub Foo::DESTROY {
+ foo(sub { });
+ return;
+}
+
+eval { foo(sub { my $o = bless {}, 'Foo'; die }) };
+is $_, "ok", 'die triggering DESTROY that calls outer sub';
+
+undef $_;
+{ foo(sub { my $o = bless {}, 'Foo'; last }) }
+is $_, "ok", 'last triggering DESTROY that calls outer sub';
+
+undef $_;
+{ foo(sub { my $o = bless {}, 'Foo'; next }) }
+is $_, "ok", 'next triggering DESTROY that calls outer sub';
+
+undef $_;
+{ if (!$count++) { foo(sub { my $o = bless {}, 'Foo'; redo }) } }
+is $_, "ok", 'redo triggering DESTROY that calls outer sub';
+
+undef $_;
+foo(sub { my $o = bless {}, 'Foo'; goto test });
+test:
+is $_, "ok", 'goto triggering DESTROY that calls outer sub';
+
+# END blocks trigger in reverse
+sub END { is $_, "ok", 'exit triggering DESTROY that calls outer sub' }
+sub END { undef $_; foo(sub { my $o = bless {}, 'Foo'; exit }); }
+
+
+sub bar {
+ my ($block) = @_;
+
+ my $got;
+ $_ = $got ? "this is clearly a bug" : "ok";
+
+ $got = 1;
+
+ my $o;
+ if ($block) {
+ $o = bless {}, "Bar";
+ $block->();
+ }
+}
+sub Bar::DESTROY {
+ bar();
+ return;
+}
+
+eval { bar(sub { die }) };
+is $_, "ok", 'die triggering DESTROY that calls current sub';
+
+undef $_;
+{ bar(sub { last }) }
+is $_, "ok", 'last triggering DESTROY that calls current sub';
+
+undef $_;
+{ bar(sub { next }) }
+is $_, "ok", 'next triggering DESTROY that calls current sub';
+
+undef $_;
+undef $count;
+{ if (!$count++) { bar(sub { redo }) } }
+is $_, "ok", 'redo triggering DESTROY that calls current sub';
+
+undef $_;
+bar(sub { goto test2 });
+test2:
+is $_, "ok", 'goto triggering DESTROY that calls current sub';
+
+sub END { is $_, "ok", 'exit triggering DESTROY that calls current sub' }
+sub END { undef $_; bar(sub { exit }) }
+
+
+format foo =
+@
+{
+ my $got;
+ $_ = $got ? "this is clearly a bug" : "ok";
+
+ $got = 1;
+
+ if ($inner_format) {
+ local $~ = $inner_format;
+ write;
+ }
+ "#"
+}
+.
+sub Foomat::DESTROY {
+ local $inner_format;
+ local $~ = "foo";
+ write;
+ return;
+}
+
+$~ = "foo";
+
+format inner_die =
+@
+{ my $o = bless {}, 'Foomat'; die }
+.
+undef $_;
+study;
+eval { local $inner_format = 'inner_die'; write };
+is $_, "ok", 'die triggering DESTROY that calls outer format';
+
+format inner_last =
+@
+{ my $o = bless {}, 'Foomat'; last LAST }
+.
+undef $_;
+LAST: { local $inner_format = 'inner_last'; write }
+is $_, "ok", 'last triggering DESTROY that calls outer format';
+
+format inner_next =
+@
+{ my $o = bless {}, 'Foomat'; next NEXT }
+.
+undef $_;
+NEXT: { local $inner_format = 'inner_next'; write }
+is $_, "ok", 'next triggering DESTROY that calls outer format';
+
+format inner_redo =
+@
+{ my $o = bless {}, 'Foomat'; redo REDO }
+.
+undef $_;
+undef $_;
+undef $count;
+REDO: { if (!$count++) { local $inner_format = 'inner_redo'; write } }
+is $_, "ok", 'redo triggering DESTROY that calls outer format';
+
+# Can't "goto" out of a pseudo block.... (another bug?)
+#format inner_goto =
+#@
+#{ my $o = bless {}, 'Foomat'; goto test3 }
+#.
+#undef $_;
+#{ local $inner_format = 'inner_goto'; write }
+#test3:
+#is $_, "ok", 'goto triggering DESTROY that calls outer format';
+
+format inner_exit =
+@
+{ my $o = bless {}, 'Foomat'; exit }
+.
+# END blocks trigger in reverse
+END { is $_, "ok", 'exit triggering DESTROY that calls outer format' }
+END { local $inner_format = 'inner_exit'; write }
+
+
+format bar =
+@
+{
+ my $got;
+ $_ = $got ? "this is clearly a bug" : "ok";
+
+ $got = 1;
+
+ my $o;
+ if ($block) {
+ $o = bless {}, "Barmat";
+ $block->();
+ }
+ "#"
+}
+.
+sub Barmat::DESTROY {
+ local $block;
+ write;
+ return;
+}
+
+$~ = "bar";
+
+undef $_;
+eval { local $block = sub { die }; write };
+is $_, "ok", 'die triggering DESTROY directly inside format';
+
+undef $_;
+LAST: { local $block = sub { last LAST }; write }
+is $_, "ok", 'last triggering DESTROY directly inside format';
+
+undef $_;
+NEXT: { local $block = sub { next NEXT }; write }
+is $_, "ok", 'next triggering DESTROY directly inside format';
+
+undef $_;
+undef $count;
+REDO: { if (!$count++) { local $block = sub { redo REDO }; write } }
+is $_, "ok", 'redo triggering DESTROY directly inside format';
+
+#undef $_;
+#{ local $block = sub { goto test4 }; write }
+#test4:
+#is $_, "ok", 'goto triggering DESTROY directly inside format';
+
+sub END { is $_, "ok", 'exit triggering DESTROY directly inside format' }
+sub END { undef $_; local $block = sub { exit }; write }
https://perl5.git.perl.org / perl5.git / commitdiff