diff options
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embedvar.h | 1 | ||||
| -rw-r--r-- | intrpvar.h | 1 | ||||
| -rw-r--r-- | pad.c | 23 | ||||
| -rw-r--r-- | pad.h | 2 | ||||
| -rw-r--r-- | pp.c | 4 | ||||
| -rw-r--r-- | pp.h | 2 | ||||
| -rw-r--r-- | pp_ctl.c | 13 | ||||
| -rw-r--r-- | proto.h | 2 | ||||
| -rw-r--r-- | t/comp/form_scope.t | 16 | ||||
| -rw-r--r-- | toke.c | 2 |
11 files changed, 46 insertions, 22 deletions
@@ -2346,7 +2346,7 @@ p |PAD ** |padlist_store |NN PADLIST *padlist|I32 key \ |NULLOK PAD *val ApdR |CV* |find_runcv |NULLOK U32 *db_seqp -pR |CV* |find_runcv_where|U8 cond|NULLOK void *arg \ +pR |CV* |find_runcv_where|U8 cond|IV arg \ |NULLOK U32 *db_seqp : Only used in perl.c p |void |free_tied_hv_pool diff --git a/embedvar.h b/embedvar.h index 0a3c7fa2d9..a2138ecdae 100644 --- a/embedvar.h +++ b/embedvar.h @@ -255,6 +255,7 @@ #define PL_pad_reset_pending (vTHX->Ipad_reset_pending) #define PL_padix (vTHX->Ipadix) #define PL_padix_floor (vTHX->Ipadix_floor) +#define PL_padlist_generation (vTHX->Ipadlist_generation) #define PL_parser (vTHX->Iparser) #define PL_patchlevel (vTHX->Ipatchlevel) #define PL_peepp (vTHX->Ipeepp) diff --git a/intrpvar.h b/intrpvar.h index c27e33893f..7dc9021adf 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -778,6 +778,7 @@ PERLVAR(I, custom_ops, HV *) /* custom op registrations */ PERLVARI(I, globhook, globhook_t, NULL) PERLVARI(I, glob_index, int, 0) +PERLVARI(I, padlist_generation, U32, 1) /* id to identify padlist clones */ PERLVAR(I, reentrant_retint, int) /* Integer return value from reentrant functions */ /* The last unconditional member of the interpreter structure when 5.10.0 was @@ -276,6 +276,7 @@ Perl_pad_new(pTHX_ int flags) AvREIFY_only(a0); } else { + padlist->xpadl_id = PL_padlist_generation++; av_store(pad, 0, NULL); } @@ -1966,18 +1967,20 @@ Perl_cv_clone(pTHX_ CV *proto) outside = find_runcv(NULL); else { outside = CvOUTSIDE(proto); - if (CvCLONE(outside) && ! CvCLONED(outside)) { - CV * const runcv = find_runcv_where( - FIND_RUNCV_root_eq, (void *)CvROOT(outside), NULL + if ((CvCLONE(outside) && ! CvCLONED(outside)) + || !CvPADLIST(outside) + || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) { + outside = find_runcv_where( + FIND_RUNCV_padid_eq, (IV)protopadlist->xpadl_outid, NULL ); - if (runcv) outside = runcv; + /* outside could be null */ } } - depth = CvDEPTH(outside); + depth = outside ? CvDEPTH(outside) : 0; assert(depth || SvTYPE(proto) == SVt_PVFM); if (!depth) depth = 1; - assert(CvPADLIST(outside) || SvTYPE(proto) == SVt_PVFM); + assert(SvTYPE(proto) == SVt_PVFM || CvPADLIST(outside)); ENTER; SAVESPTR(PL_compcv); @@ -2005,6 +2008,7 @@ Perl_cv_clone(pTHX_ CV *proto) mg_copy((SV *)proto, (SV *)cv, 0, 0); CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE); + CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id; av_fill(PL_comppad, fpad); for (ix = fname; ix > 0; ix--) @@ -2012,10 +2016,11 @@ Perl_cv_clone(pTHX_ CV *proto) PL_curpad = AvARRAY(PL_comppad); - outpad = CvPADLIST(outside) + outpad = outside && CvPADLIST(outside) ? AvARRAY(PADLIST_ARRAY(CvPADLIST(outside))[depth]) : NULL; assert(outpad || SvTYPE(cv) == SVt_PVFM); + if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id; for (ix = fpad; ix > 0; ix--) { SV* const namesv = (ix <= fname) ? pname[ix] : NULL; @@ -2026,7 +2031,7 @@ Perl_cv_clone(pTHX_ CV *proto) but state vars are always available. */ if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)]) || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv) - && !CvDEPTH(outside)) ) { + && (!outside || !CvDEPTH(outside))) ) { assert(SvTYPE(cv) == SVt_PVFM); Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), "Variable \"%"SVf"\" is not available", namesv); @@ -2063,7 +2068,7 @@ Perl_cv_clone(pTHX_ CV *proto) DEBUG_Xv( PerlIO_printf(Perl_debug_log, "\nPad CV clone\n"); - cv_dump(outside, "Outside"); + if (outside) cv_dump(outside, "Outside"); cv_dump(proto, "Proto"); cv_dump(cv, "To"); ); @@ -31,6 +31,8 @@ typedef U64TYPE PADOFFSET; struct padlist { SSize_t xpadl_max; /* max index for which array has space */ PAD ** xpadl_alloc; /* pointer to beginning of array of AVs */ + U32 xpadl_id; /* Semi-unique ID, shared between clones */ + U32 xpadl_outid; /* ID of outer pad */ }; @@ -5799,7 +5799,7 @@ PP(pp_coreargs) try_defsv: if (!numargs && defgv && whicharg == minargs + 1) { PUSHs(find_rundefsv2( - find_runcv_where(FIND_RUNCV_level_eq, (void *)1, NULL), + find_runcv_where(FIND_RUNCV_level_eq, 1, NULL), cxstack[cxstack_ix].blk_oldcop->cop_seq )); } @@ -5888,7 +5888,7 @@ PP(pp_runcv) dSP; CV *cv; if (PL_op->op_private & OPpOFFBYONE) { - cv = find_runcv_where(FIND_RUNCV_level_eq, (void *)1, NULL); + cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL); } else cv = find_runcv(NULL); XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv))); @@ -527,7 +527,7 @@ 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 +# define FIND_RUNCV_padid_eq 1 # define FIND_RUNCV_level_eq 2 #endif @@ -3227,12 +3227,12 @@ 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); + return Perl_find_runcv_where(aTHX_ 0, 0, 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) +Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) { dVAR; PERL_SI *si; @@ -3257,11 +3257,12 @@ Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp) cv = cx->blk_eval.cv; if (cv) { switch (cond) { - case FIND_RUNCV_root_eq: - if (CvROOT(cv) != (OP *)arg) continue; + case FIND_RUNCV_padid_eq: + if (!CvPADLIST(cv) + || CvPADLIST(cv)->xpadl_id != (U32)arg) continue; return cv; case FIND_RUNCV_level_eq: - if (level++ != PTR2IV(arg)) continue; + if (level++ != arg) continue; /* GERONIMO! */ default: return cv; @@ -3269,7 +3270,7 @@ Perl_find_runcv_where(pTHX_ U8 cond, void *arg, U32 *db_seqp) } } } - return cond == FIND_RUNCV_root_eq ? NULL : PL_main_cv; + return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv; } @@ -1038,7 +1038,7 @@ 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) +PERL_CALLCONV CV* Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_find_rundefsv(pTHX); diff --git a/t/comp/form_scope.t b/t/comp/form_scope.t index 4a46796fb2..2370a4bb30 100644 --- a/t/comp/form_scope.t +++ b/t/comp/form_scope.t @@ -1,6 +1,6 @@ #!./perl -print "1..13\n"; +print "1..14\n"; # Tests bug #22977. Test case from Dave Mitchell. sub f ($); @@ -133,12 +133,24 @@ do { my $t = "ok " . $testn--; write if $t =~ 12; $t} *STDOUT = *STDOUT8{FORMAT}; write; +sub _13 { + my $x; +format STDOUT13 = +@* - formats closing over redefined subs +ref \$x eq 'SCALAR' ? "ok 13" : "not ok 13"; +. +} +undef &_13; +eval 'sub _13 { my @x; write }'; +*STDOUT = *STDOUT13{FORMAT}; +_13(); + # This is a variation of bug #22977, which crashes or fails an assertion # up to 5.16. # Keep this test last if you want test numbers to be sane. BEGIN { \&END } END { - my $test = "ok 13"; + my $test = "ok 14"; *STDOUT = *STDOUT5{FORMAT}; write; format STDOUT5 = @@ -10853,6 +10853,8 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB); CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv)); CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; + if (outsidecv && CvPADLIST(outsidecv)) + CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id; return oldsavestack_ix; } |