|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
#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)
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
AvREIFY_only(a0);
}
else {
+ padlist->xpadl_id = PL_padlist_generation++;
av_store(pad, 0, NULL);
}
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);
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--)
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;
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);
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");
);
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 */
};
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
));
}
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)));
# 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
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;
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;
}
}
}
- return cond == FIND_RUNCV_root_eq ? NULL : PL_main_cv;
+ return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
}
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);
#!./perl
-print "1..13\n";
+print "1..14\n";
# Tests bug #22977. Test case from Dave Mitchell.
sub f ($);
*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 =
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;
}