/* scope.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
si->si_cxix = -1;
si->si_type = PERLSI_UNDEF;
New(56, si->si_cxstack, cxitems, PERL_CONTEXT);
+ /* Without any kind of initialising PUSHSUBST()
+ * in pp_subst() will read uninitialised heap. */
+ Poison(si->si_cxstack, cxitems, PERL_CONTEXT);
return si;
}
I32
Perl_cxinc(pTHX)
{
+ IV old_max = cxstack_max;
cxstack_max = GROW(cxstack_max);
Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); /* XXX should fix CXINC macro */
+ /* Without any kind of initialising deep enough recursion
+ * will end up reading uninitialised PERL_CONTEXTs. */
+ Poison(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT);
return cxstack_ix + 1;
}
Renew(PL_savestack, PL_savestack_max, ANY);
}
+void
+Perl_savestack_grow_cnt(pTHX_ I32 need)
+{
+ PL_savestack_max = PL_savestack_ix + need;
+ Renew(PL_savestack, PL_savestack_max, ANY);
+}
+
#undef GROW
void
PL_localizing = 1;
SvSETMAGIC(sv);
PL_localizing = 0;
- /* If we're localizing a tied array/hash element, this new sv
- * won't actually be stored in the array/hash - so it won't get
- * reaped when the localize ends. Ensure it gets reaped by
- * mortifying it instead. DAPM */
- if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
- sv_2mortal(sv);
}
return sv;
}
void
Perl_save_gp(pTHX_ GV *gv, I32 empty)
{
- SSCHECK(6);
+ SSGROW(6);
SSPUSHIV((IV)SvLEN(gv));
SvLEN(gv) = 0; /* forget that anything was allocated here */
SSPUSHIV((IV)SvCUR(gv));
}
void
+Perl_save_bool(pTHX_ bool *boolp)
+{
+ SSCHECK(3);
+ SSPUSHBOOL(*boolp);
+ SSPUSHPTR(boolp);
+ SSPUSHINT(SAVEt_BOOL);
+}
+
+void
Perl_save_I32(pTHX_ I32 *intp)
{
SSCHECK(3);
Perl_save_padsv(pTHX_ PADOFFSET off)
{
SSCHECK(4);
+ ASSERT_CURPAD_ACTIVE("save_padsv");
SSPUSHPTR(PL_curpad[off]);
- SSPUSHPTR(PL_curpad);
+ SSPUSHPTR(PL_comppad);
SSPUSHLONG((long)off);
SSPUSHINT(SAVEt_PADSV);
}
SV **
Perl_save_threadsv(pTHX_ PADOFFSET i)
{
-#ifdef USE_5005THREADS
- SV **svp = &THREADSV(i); /* XXX Change to save by offset */
- DEBUG_S(PerlIO_printf(Perl_debug_log, "save_threadsv %"UVuf": %p %p:%s\n",
- (UV)i, svp, *svp, SvPEEK(*svp)));
- save_svref(svp);
- return svp;
-#else
Perl_croak(aTHX_ "panic: save_threadsv called in non-threaded perl");
return 0;
-#endif /* USE_5005THREADS */
}
void
void
Perl_save_clearsv(pTHX_ SV **svp)
{
+ ASSERT_CURPAD_ACTIVE("save_clearsv");
SSCHECK(2);
SSPUSHLONG((long)(svp-PL_curpad));
SSPUSHINT(SAVEt_CLEARSV);
+ SvPADSTALE_off(*svp); /* mark lexical as active */
}
void
void
Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr)
{
+ SV *sv;
SSCHECK(4);
SSPUSHPTR(SvREFCNT_inc(av));
SSPUSHINT(idx);
SSPUSHPTR(SvREFCNT_inc(*sptr));
SSPUSHINT(SAVEt_AELEM);
+ /* if it gets reified later, the restore will have the wrong refcnt */
+ if (!AvREAL(av) && AvREIFY(av))
+ SvREFCNT_inc(*sptr);
save_scalar_at(sptr);
+ sv = *sptr;
+ /* If we're localizing a tied array element, this new sv
+ * won't actually be stored in the array - so it won't get
+ * reaped when the localize ends. Ensure it gets reaped by
+ * mortifying it instead. DAPM */
+ if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
+ sv_2mortal(sv);
}
void
Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
{
+ SV *sv;
SSCHECK(4);
SSPUSHPTR(SvREFCNT_inc(hv));
SSPUSHPTR(SvREFCNT_inc(key));
SSPUSHPTR(SvREFCNT_inc(*sptr));
SSPUSHINT(SAVEt_HELEM);
save_scalar_at(sptr);
+ sv = *sptr;
+ /* If we're localizing a tied hash element, this new sv
+ * won't actually be stored in the hash - so it won't get
+ * reaped when the localize ends. Ensure it gets reaped by
+ * mortifying it instead. DAPM */
+ if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
+ sv_2mortal(sv);
}
void
value = (SV*)SSPOPPTR;
gv = (GV*)SSPOPPTR;
ptr = &GvSV(gv);
- SvREFCNT_dec(gv);
+ av = (AV*)gv; /* what to refcnt_dec */
goto restore_sv;
case SAVEt_GENERIC_PVREF: /* generic pv */
str = (char*)SSPOPPTR;
case SAVEt_SVREF: /* scalar reference */
value = (SV*)SSPOPPTR;
ptr = SSPOPPTR;
+ av = Nullav; /* what to refcnt_dec */
restore_sv:
sv = *(SV**)ptr;
DEBUG_S(PerlIO_printf(Perl_debug_log,
SvSETMAGIC(value);
PL_localizing = 0;
SvREFCNT_dec(value);
+ if (av) /* actually an av, hv or gv */
+ SvREFCNT_dec(av);
break;
case SAVEt_AV: /* array reference */
av = (AV*)SSPOPPTR;
ptr = SSPOPPTR;
*(long*)ptr = (long)SSPOPLONG;
break;
+ case SAVEt_BOOL: /* bool reference */
+ ptr = SSPOPPTR;
+ *(bool*)ptr = (bool)SSPOPBOOL;
+ break;
case SAVEt_I32: /* I32 reference */
ptr = SSPOPPTR;
*(I32*)ptr = (I32)SSPOPINT;
break;
case SAVEt_FREEOP:
ptr = SSPOPPTR;
- if (PL_comppad)
- PL_curpad = AvARRAY(PL_comppad);
+ ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); /* XXX DAPM tmp */
op_free((OP*)ptr);
break;
case SAVEt_FREEPV:
case SAVEt_CLEARSV:
ptr = (void*)&PL_curpad[SSPOPLONG];
sv = *(SV**)ptr;
+
+ DEBUG_Xv(PerlIO_printf(Perl_debug_log,
+ "Pad 0x%"UVxf"[0x%"UVxf"] clearsv: %ld sv=0x%"UVxf"<%"IVdf"> %s\n",
+ PTR2UV(PL_comppad), PTR2UV(PL_curpad),
+ (long)((SV **)ptr-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
+ (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
+ ));
+
/* Can clear pad variable in place? */
if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
/*
(void)SvOOK_off(sv);
break;
}
+ SvPADSTALE_on(sv); /* mark as no longer live */
}
else { /* Someone has a claim on this, so abandon it. */
- U32 padflags = SvFLAGS(sv) & (SVs_PADBUSY|SVs_PADMY|SVs_PADTMP);
+ U32 padflags = SvFLAGS(sv) & (SVs_PADMY|SVs_PADTMP);
switch (SvTYPE(sv)) { /* Console ourselves with a new value */
case SVt_PVAV: *(SV**)ptr = (SV*)newAV(); break;
case SVt_PVHV: *(SV**)ptr = (SV*)newHV(); break;
default: *(SV**)ptr = NEWSV(0,0); break;
}
SvREFCNT_dec(sv); /* Cast current value to the winds. */
- SvFLAGS(*(SV**)ptr) |= padflags; /* preserve pad nature */
+ /* preserve pad nature, but also mark as not live
+ * for any closure capturing */
+ SvFLAGS(*(SV**)ptr) |= padflags & SVs_PADSTALE;
}
break;
case SAVEt_DELETE:
value = (SV*)SSPOPPTR;
i = SSPOPINT;
av = (AV*)SSPOPPTR;
+ if (!AvREAL(av) && AvREIFY(av)) /* undo reify guard */
+ SvREFCNT_dec(value);
ptr = av_fetch(av,i,1);
if (ptr) {
sv = *(SV**)ptr;
if (sv && sv != &PL_sv_undef) {
if (SvTIED_mg((SV*)av, PERL_MAGIC_tied))
(void)SvREFCNT_inc(sv);
- SvREFCNT_dec(av);
goto restore_sv;
}
}
ptr = &HeVAL((HE*)ptr);
if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
(void)SvREFCNT_inc(*(SV**)ptr);
- SvREFCNT_dec(hv);
SvREFCNT_dec(sv);
+ av = (AV*)hv; /* what to refcnt_dec */
goto restore_sv;
}
}
*(I32*)&PL_hints = (I32)SSPOPINT;
break;
case SAVEt_COMPPAD:
- PL_comppad = (AV*)SSPOPPTR;
+ PL_comppad = (PAD*)SSPOPPTR;
if (PL_comppad)
PL_curpad = AvARRAY(PL_comppad);
else
PADOFFSET off = (PADOFFSET)SSPOPLONG;
ptr = SSPOPPTR;
if (ptr)
- ((SV**)ptr)[off] = (SV*)SSPOPPTR;
+ AvARRAY((PAD*)ptr)[off] = (SV*)SSPOPPTR;
}
break;
default:
https://perl5.git.perl.org / perl5.git / blobdiff