[perl #119311] Keep CvDEPTH and savestack in sync

when unwinding sub and format calls.

The comments in the added test file explain what the problem is.

The fix is to call LEAVE_SCOPE in POPSUB and POPFORMAT (to free their
lexicals) before lowering CvDEPTH.

If the context has already been popped via cxstack_ix--, then
LEAVE_SCOPE could overwrite it, so accessing cx after LEAVE_SCOPE is
unsafe.  Hence the changes to POPSUB and POPFORMAT are a bit involved.
Some callers of POPSUB do a temporary cxstack_ix++ first so they
can access cx afterwards.  Two cases needed to be changed to
work that way.

diff --git a/MANIFEST b/MANIFEST
index 37221b4..b59eaef 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5303,6 +5303,7 @@ t/op/require_37033.t              See if require always closes rsfp
 t/op/require_errors.t          See if errors from require are reported correctly
 t/op/reset.t                   See if reset operator works
 t/op/reverse.t                 See if reverse operator works
+t/op/rt119311.t                        Test bug #119311 (die/DESTROY/recursion)
 t/op/runlevel.t                        See if die() works from perl_call_*()
 t/op/select.t                  See if 0- and 1-argument select works
 t/op/setpgrpstack.t            See if setpgrp works

diff --git a/cop.h b/cop.h
index 4376e62..0741d92 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -648,6 +648,7 @@ struct block_format {
 
 #define POPSUB(cx,sv)                                                  \
     STMT_START {                                                       \
+       const I32 olddepth = cx->blk_sub.olddepth;                      \
        RETURN_PROBE(CvNAMED(cx->blk_sub.cv)                            \
                        ? HEK_KEY(CvNAME_HEK(cx->blk_sub.cv))           \
                        : GvENAME(CvGV(cx->blk_sub.cv)),                \
@@ -671,7 +672,8 @@ struct block_format {
            }                                                           \
        }                                                               \
        sv = MUTABLE_SV(cx->blk_sub.cv);                                \
-       if (sv && (CvDEPTH((const CV*)sv) = cx->blk_sub.olddepth))      \
+       LEAVE_SCOPE(PL_scopestack[cx->blk_oldscopesp-1]);               \
+       if (sv && (CvDEPTH((const CV*)sv) = olddepth))                  \
            sv = NULL;                                          \
     } STMT_END
 
@@ -681,11 +683,15 @@ struct block_format {
     } STMT_END
 
 #define POPFORMAT(cx)                                                  \
-       setdefout(cx->blk_format.dfoutgv);                              \
-       CvDEPTH(cx->blk_format.cv)--;                                   \
-       if (!CvDEPTH(cx->blk_format.cv))                                \
+    STMT_START {                                                       \
+       CV * const cv = cx->blk_format.cv;                              \
+       GV * const dfuot = cx->blk_format.dfoutgv;                      \
+       setdefout(dfuot);                                               \
+       LEAVE_SCOPE(PL_scopestack[cx->blk_oldscopesp-1]);               \
+       if (!--CvDEPTH(cv))                                             \
            SvREFCNT_dec_NN(cx->blk_format.cv);                         \
-       SvREFCNT_dec_NN(cx->blk_format.dfoutgv);
+       SvREFCNT_dec_NN(dfuot);                                         \
+    } STMT_END
 
 /* eval context */
 struct block_eval {

diff --git a/pp_ctl.c b/pp_ctl.c
index 262c930..a5e293c 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2460,8 +2460,8 @@ PP(pp_return)
        }
        break;
     case CXt_FORMAT:
-       POPFORMAT(cx);
        retop = cx->blk_sub.retop;
+       POPFORMAT(cx);
        break;
     default:
        DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
@@ -2550,8 +2550,8 @@ PP(pp_leavesublv)
     S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
 
     LEAVE;
-    cxstack_ix--;
     POPSUB(cx,sv);     /* Stack values are safe: release CV and @_ ... */
+    cxstack_ix--;
     PL_curpm = newpm;  /* ... and pop $1 et al */
 
     LEAVESUB(sv);

diff --git a/pp_hot.c b/pp_hot.c
index ca95830..82c8e12 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2510,8 +2510,8 @@ PP(pp_leavesub)
     PUTBACK;
 
     LEAVE;
-    cxstack_ix--;
     POPSUB(cx,sv);     /* Stack values are safe: release CV and @_ ... */
+    cxstack_ix--;
     PL_curpm = newpm;  /* ... and pop $1 et al */
 
     LEAVESUB(sv);

diff --git a/pp_sys.c b/pp_sys.c
index b837a1e..d87299f 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1493,8 +1493,8 @@ PP(pp_leavewrite)
 
   forget_top:
     POPBLOCK(cx,PL_curpm);
-    POPFORMAT(cx);
     retop = cx->blk_sub.retop;
+    POPFORMAT(cx);
     SP = newsp; /* ignore retval of formline */
     LEAVE;
 

diff --git a/t/op/rt119311.t b/t/op/rt119311.t
new file mode 100644 (file)
index 0000000..a788a4c
--- /dev/null
+++ b/t/op/rt119311.t
@@ -0,0 +1,237 @@
+#!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 }