X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=scope.c;h=d52d12d176d73bb3743eb53db1c369e1916d6778;hb=3914f56082a0817d46ec5706e82e48b4e4e19f9d;hp=5939877a3fe681b85bb2ac8fb99898d4dc24268b;hpb=c268c2a6c105d04cb2a165c1cfb63069e7ae2774;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/scope.c b/scope.c
index 5939877..d52d12d 100644
--- a/scope.c
+++ b/scope.c
@@ -1,7 +1,7 @@
 /*    scope.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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.
@@ -62,7 +62,7 @@ Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
     Newx(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);
+    PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT);
     return si;
 }
 
@@ -75,7 +75,7 @@ Perl_cxinc(pTHX)
     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);
+    PoisonNew(cxstack + old_max + 1, cxstack_max - old_max, PERL_CONTEXT);
     return cxstack_ix + 1;
 }
 
@@ -181,12 +181,12 @@ SV *
 Perl_save_scalar(pTHX_ GV *gv)
 {
     dVAR;
-    SV ** const sptr = &GvSV(gv);
+    SV ** const sptr = &GvSVn(gv);
     PL_localizing = 1;
     SvGETMAGIC(*sptr);
     PL_localizing = 0;
     SSCHECK(3);
-    SSPUSHPTR(SvREFCNT_inc(gv));
+    SSPUSHPTR(SvREFCNT_inc_simple(gv));
     SSPUSHPTR(SvREFCNT_inc(*sptr));
     SSPUSHINT(SAVEt_SV);
     return save_scalar_at(sptr);
@@ -212,8 +212,8 @@ Perl_save_generic_pvref(pTHX_ char **str)
 {
     dVAR;
     SSCHECK(3);
-    SSPUSHPTR(str);
     SSPUSHPTR(*str);
+    SSPUSHPTR(str);
     SSPUSHINT(SAVEt_GENERIC_PVREF);
 }
 
@@ -247,20 +247,13 @@ void
 Perl_save_gp(pTHX_ GV *gv, I32 empty)
 {
     dVAR;
-    SSGROW(6);
-    SSPUSHIV((IV)SvLEN(gv));
-    SvLEN_set(gv, 0); /* forget that anything was allocated here */
-    SSPUSHIV((IV)SvCUR(gv));
-    SSPUSHPTR(SvPVX_const(gv));
-    SvPOK_off(gv);
+    SSGROW(3);
     SSPUSHPTR(SvREFCNT_inc(gv));
     SSPUSHPTR(GvGP(gv));
     SSPUSHINT(SAVEt_GP);
 
     if (empty) {
-	register GP *gp;
-
-	Newxz(gp, 1, GP);
+	GP *gp = Perl_newGP(aTHX_ gv);
 
 	if (GvCVu(gv))
 	    PL_sub_generation++;	/* taking a method out of circulation */
@@ -268,13 +261,7 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty)
 	    gp->gp_io = newIO();
 	    IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
 	}
-	GvGP(gv) = gp_ref(gp);
-	GvSV(gv) = newSV(0);
-	GvLINE(gv) = CopLINE(PL_curcop);
-	/* XXX Ideally this cast would be replaced with a change to const char*
-	   in the struct.  */
-	GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) "";
-	GvEGV(gv) = gv;
+	GvGP(gv) = gp;
     }
     else {
 	gp_ref(GvGP(gv));
@@ -296,7 +283,7 @@ Perl_save_ary(pTHX_ GV *gv)
     SSPUSHPTR(oav);
     SSPUSHINT(SAVEt_AV);
 
-    GvAV(gv) = Null(AV*);
+    GvAV(gv) = NULL;
     av = GvAVn(gv);
     if (SvMAGIC(oav))
 	mg_localize((SV*)oav, (SV*)av);
@@ -314,7 +301,7 @@ Perl_save_hash(pTHX_ GV *gv)
     SSPUSHPTR(ohv = GvHVn(gv));
     SSPUSHINT(SAVEt_HV);
 
-    GvHV(gv) = Null(HV*);
+    GvHV(gv) = NULL;
     hv = GvHVn(gv);
     if (SvMAGIC(ohv))
 	mg_localize((SV*)ohv, (SV*)hv);
@@ -354,6 +341,16 @@ Perl_save_bool(pTHX_ bool *boolp)
 }
 
 void
+Perl_save_I8(pTHX_ I8 *bytep)
+{
+    dVAR;
+    SSCHECK(3);
+    SSPUSHINT(*bytep);
+    SSPUSHPTR(bytep);
+    SSPUSHINT(SAVEt_I8);
+}
+
+void
 Perl_save_I32(pTHX_ I32 *intp)
 {
     dVAR;
@@ -482,11 +479,21 @@ Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
     SSCHECK(4);
     SSPUSHINT(klen);
     SSPUSHPTR(key);
-    SSPUSHPTR(SvREFCNT_inc(hv));
+    SSPUSHPTR(SvREFCNT_inc_simple(hv));
     SSPUSHINT(SAVEt_DELETE);
 }
 
 void
+Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
+{
+    dVAR;
+    SSCHECK(3);
+    SSPUSHDPTR(f);
+    SSPUSHPTR(p);
+    SSPUSHINT(SAVEt_DESTRUCTOR);
+}
+
+void
 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
 {
     dVAR;
@@ -497,19 +504,19 @@ Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
 }
 
 void
-Perl_save_aelem(pTHX_ const AV *av, I32 idx, SV **sptr)
+Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr)
 {
     dVAR;
     SV *sv;
     SvGETMAGIC(*sptr);
     SSCHECK(4);
-    SSPUSHPTR(SvREFCNT_inc(av));
+    SSPUSHPTR(SvREFCNT_inc_simple(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))
-        (void)SvREFCNT_inc(*sptr);
+	SvREFCNT_inc_void(*sptr);
     save_scalar_at(sptr);
     sv = *sptr;
     /* If we're localizing a tied array element, this new sv
@@ -527,8 +534,8 @@ Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
     SV *sv;
     SvGETMAGIC(*sptr);
     SSCHECK(4);
-    SSPUSHPTR(SvREFCNT_inc(hv));
-    SSPUSHPTR(SvREFCNT_inc(key));
+    SSPUSHPTR(SvREFCNT_inc_simple(hv));
+    SSPUSHPTR(SvREFCNT_inc_simple(key));
     SSPUSHPTR(SvREFCNT_inc(*sptr));
     SSPUSHINT(SAVEt_HELEM);
     save_scalar_at(sptr);
@@ -570,9 +577,7 @@ Perl_save_alloc(pTHX_ I32 size, I32 pad)
 				- (char*)PL_savestack);
     register const I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
 
-    /* SSCHECK may not be good enough */
-    while (PL_savestack_ix + elems + 2 > PL_savestack_max)
-	savestack_grow();
+    SSGROW(elems + 2);
 
     PL_savestack_ix += elems;
     SSPUSHINT(elems);
@@ -614,7 +619,8 @@ Perl_leave_scope(pTHX_ I32 base)
 	    sv = *(SV**)ptr;
 	    DEBUG_S(PerlIO_printf(Perl_debug_log,
 				  "restore svref: %p %p:%s -> %p:%s\n",
-				  ptr, sv, SvPEEK(sv), value, SvPEEK(value)));
+				  (void*)ptr, (void*)sv, SvPEEK(sv),
+				  (void*)value, SvPEEK(value)));
 	    *(SV**)ptr = value;
 	    SvREFCNT_dec(sv);
 	    PL_localizing = 2;
@@ -625,8 +631,8 @@ Perl_leave_scope(pTHX_ I32 base)
 		SvREFCNT_dec(av);
 	    break;
 	case SAVEt_GENERIC_PVREF:		/* generic pv */
-	    str = (char*)SSPOPPTR;
 	    ptr = SSPOPPTR;
+	    str = (char*)SSPOPPTR;
 	    if (*(char**)ptr != str) {
 		Safefree(*(char**)ptr);
 		*(char**)ptr = str;
@@ -701,7 +707,15 @@ Perl_leave_scope(pTHX_ I32 base)
 	    break;
 	case SAVEt_I32:				/* I32 reference */
 	    ptr = SSPOPPTR;
+#ifdef PERL_DEBUG_READONLY_OPS
+	    {
+		const I32 val = SSPOPINT;
+		if (*(I32*)ptr != val)
+		    *(I32*)ptr = val;
+	    }
+#else
 	    *(I32*)ptr = (I32)SSPOPINT;
+#endif
 	    break;
 	case SAVEt_SPTR:			/* SV* reference */
 	    ptr = SSPOPPTR;
@@ -723,12 +737,6 @@ Perl_leave_scope(pTHX_ I32 base)
 	case SAVEt_GP:				/* scalar reference */
 	    ptr = SSPOPPTR;
 	    gv = (GV*)SSPOPPTR;
-	    if (SvPVX_const(gv) && SvLEN(gv) > 0) {
-		Safefree(SvPVX_mutable(gv));
-	    }
-	    SvPV_set(gv, (char *)SSPOPPTR);
-	    SvCUR_set(gv, (STRLEN)SSPOPIV);
-	    SvLEN_set(gv, (STRLEN)SSPOPIV);
 	    gp_free(gv);
 	    GvGP(gv) = (GP*)ptr;
 	    if (GvCVu(gv))
@@ -812,7 +820,7 @@ Perl_leave_scope(pTHX_ I32 base)
 	    ptr = SSPOPPTR;
 	    hv = (HV*)ptr;
 	    ptr = SSPOPPTR;
-	    (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
+	    (void)hv_delete(hv, (char*)ptr, (I32)SSPOPINT, G_DISCARD);
 	    SvREFCNT_dec(hv);
 	    Safefree(ptr);
 	    break;
@@ -829,18 +837,22 @@ Perl_leave_scope(pTHX_ I32 base)
 	    i = SSPOPINT;
 	    PL_stack_sp = PL_stack_base + i;
 	    break;
+	case SAVEt_STACK_CXPOS:         /* blk_oldsp on context stack */
+	    i = SSPOPINT;
+	    cxstack[i].blk_oldsp = SSPOPINT;
+	    break;
 	case SAVEt_AELEM:		/* array element */
 	    value = (SV*)SSPOPPTR;
 	    i = SSPOPINT;
 	    av = (AV*)SSPOPPTR;
+	    ptr = av_fetch(av,i,1);
 	    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_inc_void_NN(sv);
 		    goto restore_sv;
 		}
 	    }
@@ -857,7 +869,7 @@ Perl_leave_scope(pTHX_ I32 base)
 		if (oval && oval != &PL_sv_undef) {
 		    ptr = &HeVAL((HE*)ptr);
 		    if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
-			(void)SvREFCNT_inc(*(SV**)ptr);
+			SvREFCNT_inc_void(*(SV**)ptr);
 		    SvREFCNT_dec(sv);
 		    av = (AV*)hv; /* what to refcnt_dec */
 		    goto restore_sv;
@@ -876,18 +888,40 @@ Perl_leave_scope(pTHX_ I32 base)
 		GvHV(PL_hintgv) = NULL;
 	    }
 	    *(I32*)&PL_hints = (I32)SSPOPINT;
+	    Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+	    PL_compiling.cop_hints_hash = (struct refcounted_he *) SSPOPPTR;
 	    if (PL_hints & HINT_LOCALIZE_HH) {
 		SvREFCNT_dec((SV*)GvHV(PL_hintgv));
 		GvHV(PL_hintgv) = (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.  */
+
+		HV *const hv = newHV();
+		hv_magic(hv, NULL, PERL_MAGIC_hints);
+		GvHV(PL_hintgv) = hv;
 	    }
-		    
+	    assert(GvHV(PL_hintgv));
 	    break;
 	case SAVEt_COMPPAD:
 	    PL_comppad = (PAD*)SSPOPPTR;
 	    if (PL_comppad)
 		PL_curpad = AvARRAY(PL_comppad);
 	    else
-		PL_curpad = Null(SV**);
+		PL_curpad = NULL;
 	    break;
 	case SAVEt_PADSV:
 	    {
@@ -945,6 +979,40 @@ 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;
+
+	    if (!specialWARN(PL_compiling.cop_warnings))
+		PerlMemShared_free(PL_compiling.cop_warnings);
+
+	    PL_compiling.cop_warnings = (STRLEN*)ptr;
+	    break;
+	case SAVEt_RE_STATE:
+	    {
+		const struct re_save_state *const state
+		    = (struct re_save_state *)
+		    (PL_savestack + PL_savestack_ix
+		     - 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);
+		}
+		Copy(state, &PL_reg_state, 1, struct re_save_state);
+	    }
+	    break;
+	case SAVEt_PARSER:
+	    ptr = SSPOPPTR;
+	    parser_free((yy_parser *) ptr);
+	    break;
 	default:
 	    Perl_croak(aTHX_ "panic: leave_scope inconsistency");
 	}
@@ -1015,12 +1083,10 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
 		cx->blk_loop.label);
 	PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
 		(long)cx->blk_loop.resetsp);
-	PerlIO_printf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%"UVxf"\n",
-		PTR2UV(cx->blk_loop.redo_op));
+	PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%"UVxf"\n",
+		PTR2UV(cx->blk_loop.my_op));
 	PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%"UVxf"\n",
-		PTR2UV(cx->blk_loop.next_op));
-	PerlIO_printf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%"UVxf"\n",
-		PTR2UV(cx->blk_loop.last_op));
+		PTR2UV(CX_LOOP_NEXTOP_GET(cx)));
 	PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
 		(long)cx->blk_loop.iterix);
 	PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
@@ -1060,6 +1126,7 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
 	break;
     }
 #else
+    PERL_UNUSED_CONTEXT;
     PERL_UNUSED_ARG(cx);
 #endif	/* DEBUGGING */
 }