X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2dcac756b8b2c3b3d7d34174ba27b78fb1c7ba4a..90249f0ae5df4271829a2e527b72534b8974ec80:/scope.c

diff --git a/scope.c b/scope.c
index fb93db0..c767571 100644
--- a/scope.c
+++ b/scope.c
@@ -160,8 +160,10 @@ Perl_free_tmps(pTHX)
     /* XXX should tmps_floor live in cxstack? */
     const I32 myfloor = PL_tmps_floor;
     while (PL_tmps_ix > myfloor) {      /* clean up after last statement */
-	SV* const sv = PL_tmps_stack[PL_tmps_ix];
-	PL_tmps_stack[PL_tmps_ix--] = NULL;
+	SV* const sv = PL_tmps_stack[PL_tmps_ix--];
+#ifdef PERL_POISON
+	PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
+#endif
 	if (sv && sv != &PL_sv_undef) {
 	    SvTEMP_off(sv);
 	    SvREFCNT_dec(sv);		/* note, can modify tmps_ix!!! */
@@ -174,14 +176,14 @@ S_save_scalar_at(pTHX_ SV **sptr, const U32 flags)
 {
     dVAR;
     SV * osv;
-    register SV *sv;
+    SV *sv;
 
     PERL_ARGS_ASSERT_SAVE_SCALAR_AT;
 
     osv = *sptr;
     sv  = (flags & SAVEf_KEEPOLDELEM) ? osv : (*sptr = newSV(0));
 
-    if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
+    if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv)) {
 	if (SvGMAGICAL(osv)) {
 	    SvFLAGS(osv) |= (SvFLAGS(osv) &
 	       (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
@@ -298,7 +300,7 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty)
 	    gp->gp_sv = newSV(0);
 	}
 #endif
-	GvGP(gv) = gp;
+	GvGP_set(gv,gp);
     }
     else {
 	gp_ref(GvGP(gv));
@@ -317,7 +319,7 @@ Perl_save_ary(pTHX_ GV *gv)
 
     if (!AvREAL(oav) && AvREIFY(oav))
 	av_reify(oav);
-    save_pushptrptr(gv, oav, SAVEt_AV);
+    save_pushptrptr(SvREFCNT_inc_simple_NN(gv), oav, SAVEt_AV);
 
     GvAV(gv) = NULL;
     av = GvAVn(gv);
@@ -334,7 +336,9 @@ Perl_save_hash(pTHX_ GV *gv)
 
     PERL_ARGS_ASSERT_SAVE_HASH;
 
-    save_pushptrptr(gv, (ohv = GvHVn(gv)), SAVEt_HV);
+    save_pushptrptr(
+	SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV
+    );
 
     GvHV(gv) = NULL;
     hv = GvHVn(gv);
@@ -347,7 +351,7 @@ void
 Perl_save_item(pTHX_ register SV *item)
 {
     dVAR;
-    register SV * const sv = newSVsv(item);
+    SV * const sv = newSVsv(item);
 
     PERL_ARGS_ASSERT_SAVE_ITEM;
 
@@ -592,8 +596,10 @@ Perl_save_hints(pTHX)
     dVAR;
     COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling));
     if (PL_hints & HINT_LOCALIZE_HH) {
-	save_pushptri32ptr(GvHV(PL_hintgv), PL_hints, save_cophh, SAVEt_HINTS);
-	GvHV(PL_hintgv) = hv_copy_hints_hv(GvHV(PL_hintgv));
+	HV *oldhh = GvHV(PL_hintgv);
+	save_pushptri32ptr(oldhh, PL_hints, save_cophh, SAVEt_HINTS);
+	GvHV(PL_hintgv) = NULL; /* in case copying dies */
+	GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh);
     } else {
 	save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS);
     }
@@ -678,8 +684,8 @@ I32
 Perl_save_alloc(pTHX_ I32 size, I32 pad)
 {
     dVAR;
-    register const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
-				- (char*)PL_savestack);
+    const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
+                          - (char*)PL_savestack);
     const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
     const UV elems_shifted = elems << SAVE_TIGHT_SHIFT;
 
@@ -698,19 +704,19 @@ void
 Perl_leave_scope(pTHX_ I32 base)
 {
     dVAR;
-    register SV *sv;
-    register SV *value;
-    register GV *gv;
-    register AV *av;
-    register HV *hv;
+    SV *sv;
+    SV *value;
+    GV *gv;
+    AV *av;
+    HV *hv;
     void* ptr;
-    register char* str;
+    char* str;
     I32 i;
     /* Localise the effects of the TAINT_NOT inside the loop.  */
-    const bool was = PL_tainted;
+    bool was = PL_tainted;
 
     if (base < -1)
-	Perl_croak(aTHX_ "panic: corrupt saved stack index");
+	Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base);
     DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
 			(long)PL_savestack_ix, (long)base));
     while (PL_savestack_ix > base) {
@@ -740,8 +746,7 @@ 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);
+	    SvREFCNT_dec(av); /* av may actually be an AV, HV or GV */
 	    break;
 	case SAVEt_GENERIC_PVREF:		/* generic pv */
 	    ptr = SSPOPPTR;
@@ -787,6 +792,7 @@ Perl_leave_scope(pTHX_ I32 base)
 		SvSETMAGIC(MUTABLE_SV(av));
 		PL_localizing = 0;
 	    }
+	    SvREFCNT_dec(gv);
 	    break;
 	case SAVEt_HV:				/* hash reference */
 	    hv = MUTABLE_HV(SSPOPPTR);
@@ -798,6 +804,7 @@ Perl_leave_scope(pTHX_ I32 base)
 		SvSETMAGIC(MUTABLE_SV(hv));
 		PL_localizing = 0;
 	    }
+	    SvREFCNT_dec(gv);
 	    break;
 	case SAVEt_INT_SMALL:
 	    ptr = SSPOPPTR;
@@ -810,6 +817,15 @@ Perl_leave_scope(pTHX_ I32 base)
 	case SAVEt_BOOL:			/* bool reference */
 	    ptr = SSPOPPTR;
 	    *(bool*)ptr = cBOOL(uv >> 8);
+
+	    if (ptr == &PL_tainted) {
+		/* If we don't update <was>, to reflect what was saved on the
+		 * stack for PL_tainted, then we will overwrite this attempt to
+		 * restore it when we exit this routine.  Note that this won't
+		 * work if this value was saved in a wider-than necessary type,
+		 * such as I32 */
+		was = *(bool*)ptr;
+	    }
 	    break;
 	case SAVEt_I32_SMALL:
 	    ptr = SSPOPPTR;
@@ -848,7 +864,7 @@ Perl_leave_scope(pTHX_ I32 base)
 	    ptr = SSPOPPTR;
 	    gv = MUTABLE_GV(SSPOPPTR);
 	    gp_free(gv);
-	    GvGP(gv) = (GP*)ptr;
+	    GvGP_set(gv, (GP*)ptr);
             /* putting a method back into circulation ("local")*/
 	    if (GvCVu(gv) && (hv=GvSTASH(gv)) && HvENAME_get(hv))
                 mro_method_changed_in(hv);
@@ -897,9 +913,16 @@ Perl_leave_scope(pTHX_ I32 base)
 		    SvREADONLY_off(sv);
 
 		if (SvTHINKFIRST(sv))
-		    sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF);
+		    sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF
+					     |SV_COW_DROP_PV);
+		if (SvTYPE(sv) == SVt_PVHV)
+		    Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
 		if (SvMAGICAL(sv))
+		{
+		  sv_unmagic(sv, PERL_MAGIC_backref);
+		  if (SvTYPE(sv) != SVt_PVCV)
 		    mg_free(sv);
+		}
 
 		switch (SvTYPE(sv)) {
 		case SVt_NULL:
@@ -911,7 +934,14 @@ Perl_leave_scope(pTHX_ I32 base)
 		    hv_clear(MUTABLE_HV(sv));
 		    break;
 		case SVt_PVCV:
-		    Perl_croak(aTHX_ "panic: leave_scope pad code");
+		{
+		    HEK * const hek = CvNAME_HEK((CV *)sv);
+		    assert(hek);
+		    share_hek_hek(hek);
+		    cv_undef((CV *)sv);
+		    CvNAME_HEK_set(sv, hek);
+		    break;
+		}
 		default:
 		    SvOK_off(sv);
 		    break;
@@ -919,16 +949,30 @@ Perl_leave_scope(pTHX_ I32 base)
 		SvPADSTALE_on(sv); /* mark as no longer live */
 	    }
 	    else {	/* Someone has a claim on this, so abandon it. */
-		const U32 padflags = SvFLAGS(sv) & (SVs_PADMY|SVs_PADTMP);
+		assert(  SvFLAGS(sv) & SVs_PADMY);
+		assert(!(SvFLAGS(sv) & SVs_PADTMP));
 		switch (SvTYPE(sv)) {	/* Console ourselves with a new value */
 		case SVt_PVAV:	*(SV**)ptr = MUTABLE_SV(newAV());	break;
 		case SVt_PVHV:	*(SV**)ptr = MUTABLE_SV(newHV());	break;
+		case SVt_PVCV:
+		{
+		    SV ** const svp = (SV **)ptr;
+
+		    /* Create a stub */
+		    *svp = newSV_type(SVt_PVCV);
+
+		    /* Share name */
+		    assert(CvNAMED(sv));
+		    CvNAME_HEK_set(*svp,
+			share_hek_hek(CvNAME_HEK((CV *)sv)));
+		    break;
+		}
 		default:	*(SV**)ptr = newSV(0);		break;
 		}
 		SvREFCNT_dec(sv);	/* Cast current value to the winds. */
 		/* preserve pad nature, but also mark as not live
 		 * for any closure capturing */
-		SvFLAGS(*(SV**)ptr) |= padflags | SVs_PADSTALE;
+		SvFLAGS(*(SV**)ptr) |= (SVs_PADMY|SVs_PADSTALE);
 	    }
 	    break;
 	case SAVEt_DELETE:
@@ -1005,9 +1049,12 @@ 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(MUTABLE_SV(GvHV(PL_hintgv)));
+	    if ((PL_hints & HINT_LOCALIZE_HH)) {
+	      while (GvHV(PL_hintgv)) {
+		HV *hv = GvHV(PL_hintgv);
 		GvHV(PL_hintgv) = NULL;
+		SvREFCNT_dec(MUTABLE_SV(hv));
+	      }
 	    }
 	    cophh_free(CopHINTHASH_get(&PL_compiling));
 	    CopHINTHASH_set(&PL_compiling, (COPHH*)SSPOPPTR);
@@ -1015,23 +1062,10 @@ Perl_leave_scope(pTHX_ I32 base)
 	    if (PL_hints & HINT_LOCALIZE_HH) {
 		SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
 		GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
-		assert(GvHV(PL_hintgv));
-	    } else if (!GvHV(PL_hintgv)) {
-		/* Need to add a new one manually, else gv_fetchpv() can
-		   add one in this code:
-		   
-		   if (SvTYPE(gv) == SVt_PVGV) {
-		       if (add) {
-		       GvMULTI_on(gv);
-		       gv_init_sv(gv, sv_type);
-		       if (*name=='!' && sv_type == SVt_PVHV && len==1)
-			   require_errno(gv);
-		       }
-		       return gv;
-		   }
-
-		   and it won't have the magic set.  */
-
+	    }
+	    if (!GvHV(PL_hintgv)) {
+		/* Need to add a new one manually, else rv2hv can
+		   add one via GvHVn and it won't have the magic set.  */
 		HV *const hv = newHV();
 		hv_magic(hv, NULL, PERL_MAGIC_hints);
 		GvHV(PL_hintgv) = hv;
@@ -1112,11 +1146,6 @@ Perl_leave_scope(pTHX_ I32 base)
 	    ptr = SSPOPPTR;
 	    (*SSPOPDPTR)(ptr);
 	    break;
-	case SAVEt_COP_ARYBASE:
-	    ptr = SSPOPPTR;
-	    i = SSPOPINT;
-	    CopARYBASE_set((COP *)ptr, i);
-	    break;
 	case SAVEt_COMPILE_WARNINGS:
 	    ptr = SSPOPPTR;
 
@@ -1133,9 +1162,6 @@ Perl_leave_scope(pTHX_ I32 base)
 		     - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
 		PL_savestack_ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
 
-		if (PL_reg_start_tmp != state->re_state_reg_start_tmp) {
-		    Safefree(PL_reg_start_tmp);
-		}
 		if (PL_reg_poscache != state->re_state_reg_poscache) {
 		    Safefree(PL_reg_poscache);
 		}
@@ -1147,7 +1173,7 @@ Perl_leave_scope(pTHX_ I32 base)
 	    parser_free((yy_parser *) ptr);
 	    break;
 	default:
-	    Perl_croak(aTHX_ "panic: leave_scope inconsistency");
+	    Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
 	}
     }
 
@@ -1166,6 +1192,7 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
 #ifdef DEBUGGING
     PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
     if (CxTYPE(cx) != CXt_SUBST) {
+	const char *gimme_text;
 	PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
 	PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
 		      PTR2UV(cx->blk_oldcop));
@@ -1173,7 +1200,21 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
 	PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
 	PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
 		      PTR2UV(cx->blk_oldpm));
-	PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
+	switch (cx->blk_gimme) {
+	    case G_VOID:
+		gimme_text = "VOID";
+		break;
+	    case G_SCALAR:
+		gimme_text = "SCALAR";
+		break;
+	    case G_ARRAY:
+		gimme_text = "LIST";
+		break;
+	    default:
+		gimme_text = "UNKNOWN";
+		break;
+	}
+	PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text);
     }
     switch (CxTYPE(cx)) {
     case CXt_NULL:
@@ -1270,8 +1311,8 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
  * End:
  *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
  */