Make formats close over the right closure

This was brought up in ticket #113812.

Formats that are nested inside closures only work if invoked from
directly inside that closure.  Calling the format from an inner sub
call won’t work.

Commit af41786fe57 stopped it from crashing, making it work as well
as 5.8, in that closed-over variables would be undefined, being
unavailable.

This commit adds a variation of the find_runcv function that can check
whether CvROOT matches an argument passed in.  So we look not for the
current sub, but for the topmost sub on the call stack that is a clone
of the closure prototype that the format’s CvOUTSIDE field points to.

diff --git a/embed.fnc b/embed.fnc
index b79341b..c16dde8 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2327,6 +2327,8 @@ pdR       |AV*    |padlist_dup    |NULLOK AV *srcpad|NN CLONE_PARAMS *param
 #endif
 
 ApdR   |CV*    |find_runcv     |NULLOK U32 *db_seqp
+pR     |CV*    |find_runcv_where|U8 cond|NULLOK void *arg \
+                                |NULLOK U32 *db_seqp
 : Only used in perl.c
 p      |void   |free_tied_hv_pool
 #if defined(DEBUGGING)

diff --git a/embed.h b/embed.h
index 00b54fa..720e253 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1077,6 +1077,7 @@
 #define dump_packsubs_perl(a,b)        Perl_dump_packsubs_perl(aTHX_ a,b)
 #define dump_sub_perl(a,b)     Perl_dump_sub_perl(aTHX_ a,b)
 #define finalize_optree(a)     Perl_finalize_optree(aTHX_ a)
+#define find_runcv_where(a,b,c)        Perl_find_runcv_where(aTHX_ a,b,c)
 #define find_rundefsv2(a,b)    Perl_find_rundefsv2(aTHX_ a,b)
 #define find_script(a,b,c,d)   Perl_find_script(aTHX_ a,b,c,d)
 #define free_tied_hv_pool()    Perl_free_tied_hv_pool(aTHX)

diff --git a/pad.c b/pad.c
index 8609156..1870ab6 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1934,9 +1934,10 @@ Perl_cv_clone(pTHX_ CV *proto)
     else {
        outside = CvOUTSIDE(proto);
        if (CvCLONE(outside) && ! CvCLONED(outside)) {
-           CV * const runcv = find_runcv(NULL);
-           if (CvROOT(runcv) == CvROOT(outside))
-               outside = runcv;
+           CV * const runcv = find_runcv_where(
+               FIND_RUNCV_root_eq, (void *)CvROOT(outside), NULL
+           );
+           if (runcv) outside = runcv;
        }
     }
     depth = CvDEPTH(outside);

diff --git a/pp.h b/pp.h
index 4661f42..e684ce9 100644 (file)
--- a/pp.h
+++ b/pp.h
@@ -526,6 +526,8 @@ True if this op will be the return value of an lvalue subroutine
 #  define MAYBE_DEREF_GV(sv)      MAYBE_DEREF_GV_flags(sv,SV_GMAGIC)
 #  define MAYBE_DEREF_GV_nomg(sv) MAYBE_DEREF_GV_flags(sv,0)
 
+#  define FIND_RUNCV_root_eq   1
+
 #endif
 
 /*

diff --git a/pp_ctl.c b/pp_ctl.c
index f3c7692..0fee02a 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3245,6 +3245,13 @@ than in the scope of the debugger itself).
 CV*
 Perl_find_runcv(pTHX_ U32 *db_seqp)
 {
+    return Perl_find_runcv_where(aTHX_ 0, NULL, db_seqp);
+}
+
+/* If this becomes part of the API, it might need a better name. */
+CV *
+Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp)
+{
     dVAR;
     PERL_SI     *si;
 
@@ -3254,20 +3261,29 @@ Perl_find_runcv(pTHX_ U32 *db_seqp)
         I32 ix;
        for (ix = si->si_cxix; ix >= 0; ix--) {
            const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
+           CV *cv = NULL;
            if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
-               CV * const cv = cx->blk_sub.cv;
+               cv = cx->blk_sub.cv;
                /* skip DB:: code */
                if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
                    *db_seqp = cx->blk_oldcop->cop_seq;
                    continue;
                }
-               return cv;
            }
            else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
-               return cx->blk_eval.cv;
+               cv = cx->blk_eval.cv;
+           if (cv) {
+               switch (cond) {
+               case FIND_RUNCV_root_eq:
+                   if (CvROOT(cv) != (OP *)arg) continue;
+                   /* GERONIMO! */
+               default:
+                   return cv;
+               }
+           }
        }
     }
-    return PL_main_cv;
+    return cond == FIND_RUNCV_root_eq ? NULL : PL_main_cv;
 }
 
 

diff --git a/proto.h b/proto.h
index bfa685c..272f486 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1032,6 +1032,9 @@ PERL_CALLCONV void        Perl_finalize_optree(pTHX_ OP* o)
 PERL_CALLCONV CV*      Perl_find_runcv(pTHX_ U32 *db_seqp)
                        __attribute__warn_unused_result__;
 
+PERL_CALLCONV CV*      Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp)
+                       __attribute__warn_unused_result__;
+
 PERL_CALLCONV SV*      Perl_find_rundefsv(pTHX);
 PERL_CALLCONV SV*      Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
                        __attribute__nonnull__(pTHX_1);

diff --git a/t/comp/form_scope.t b/t/comp/form_scope.t
index ac106e8..d805ffa 100644 (file)
--- a/t/comp/form_scope.t
+++ b/t/comp/form_scope.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..5\n";
+print "1..7\n";
 
 # Tests bug #22977.  Test case from Dave Mitchell.
 sub f ($);
@@ -74,3 +74,26 @@ defined $x ? "not ok 4 - $x" : "ok 4"
   print "not " unless $w =~ /^Variable "\$x" is not available at/;
   print "ok 5 - closure var not available when outer sub is inactive\n";
 }
+
+# Formats inside closures should close over the topmost clone of the outer
+# sub on the call stack.
+# Tests will be out of sequence if the wrong sub is used.
+sub make_closure {
+  my $arg = shift;
+  sub {
+    shift == 0 and &$next(1), return;
+    my $x = "ok $arg";
+    format STDOUT4 =
+@<<<<<<<
+$x
+.
+    sub { write }->(); # separate sub, so as not to rely on it being the
+  }                    # currently-running sub
+}
+*STDOUT = *STDOUT4{FORMAT};
+$clo1 = make_closure 6;
+$clo2 = make_closure 7;
+$next = $clo1;
+&$clo2(0);
+$next = $clo2;
+&$clo1(0);