X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=scope.c;h=932390de0f086b99d8a36837fb947594c8b1cd64;hb=5cfbcfcdc45b1cdd758241f7f02495ded7acc722;hp=3303011393edac7a69ca920c8027daefe2d2d7e7;hpb=235bddc8d16c512a7d89f327f65cee68b1f5848c;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/scope.c b/scope.c
index 3303011..932390d 100644
--- a/scope.c
+++ b/scope.c
@@ -1,6 +1,7 @@
 /*    scope.c
  *
- *    Copyright (c) 1991-2001, 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.
@@ -81,14 +82,21 @@ Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
     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;
 }
 
@@ -384,6 +392,15 @@ Perl_save_long(pTHX_ long int *longp)
 }
 
 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);
@@ -453,8 +470,9 @@ void
 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);
 }
@@ -462,16 +480,8 @@ Perl_save_padsv(pTHX_ PADOFFSET off)
 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
@@ -535,9 +545,11 @@ Perl_save_freepv(pTHX_ char *pv)
 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
@@ -587,23 +599,42 @@ Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
 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
@@ -659,7 +690,7 @@ Perl_leave_scope(pTHX_ I32 base)
 	    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;
@@ -673,7 +704,11 @@ Perl_leave_scope(pTHX_ I32 base)
 	    str = (char*)SSPOPPTR;
 	    ptr = SSPOPPTR;
 	    if (*(char**)ptr != str) {
+#ifdef NETWARE
+		PerlMem_free(*(char**)ptr);
+#else
 		PerlMemShared_free(*(char**)ptr);
+#endif
 		*(char**)ptr = str;
 	    }
 	    break;
@@ -688,6 +723,7 @@ Perl_leave_scope(pTHX_ I32 base)
 	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,
@@ -723,6 +759,8 @@ Perl_leave_scope(pTHX_ I32 base)
 	    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;
@@ -768,6 +806,10 @@ Perl_leave_scope(pTHX_ I32 base)
 	    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;
@@ -830,8 +872,7 @@ Perl_leave_scope(pTHX_ I32 base)
 	    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:
@@ -841,6 +882,14 @@ Perl_leave_scope(pTHX_ I32 base)
 	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)) {
 		/*
@@ -877,16 +926,19 @@ Perl_leave_scope(pTHX_ I32 base)
 		    (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:
@@ -918,13 +970,14 @@ Perl_leave_scope(pTHX_ I32 base)
 	    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;
 		}
 	    }
@@ -942,8 +995,8 @@ Perl_leave_scope(pTHX_ I32 base)
 		    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;
 		}
 	    }
@@ -955,10 +1008,14 @@ Perl_leave_scope(pTHX_ I32 base)
 	    PL_op = (OP*)SSPOPPTR;
 	    break;
 	case SAVEt_HINTS:
+	    if ((PL_hints & HINT_LOCALIZE_HH) && GvHV(PL_hintgv)) {
+		SvREFCNT_dec((SV*)GvHV(PL_hintgv));
+		GvHV(PL_hintgv) = NULL;
+	    }
 	    *(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
@@ -969,7 +1026,7 @@ Perl_leave_scope(pTHX_ I32 base)
 		PADOFFSET off = (PADOFFSET)SSPOPLONG;
 		ptr = SSPOPPTR;
 		if (ptr)
-		    ((SV**)ptr)[off] = (SV*)SSPOPPTR;
+		    AvARRAY((PAD*)ptr)[off] = (SV*)SSPOPPTR;
 	    }
 	    break;
 	default: