X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=368525274b79730090541820963eb1e36ebeae91;hb=48c036b1eb8f866b948f33704ee6152323a5aad9;hp=8bb6c1474029a3bd0e5b537ad5b38a9e8c83f502;hpb=ff3bd04127522869a3afae2fde23c6b52ab6c7de;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/sv.c b/sv.c
index 8bb6c14..3685252 100644
--- a/sv.c
+++ b/sv.c
@@ -335,8 +335,19 @@ do_clean_objs(SV *sv)
 static void
 do_clean_named_objs(SV *sv)
 {
-    if (SvTYPE(sv) == SVt_PVGV && GvSV(sv))
-	do_clean_objs(GvSV(sv));
+    if (SvTYPE(sv) == SVt_PVGV) {
+	if ( SvOBJECT(GvSV(sv)) ||
+	     GvAV(sv) && SvOBJECT(GvAV(sv)) ||
+	     GvHV(sv) && SvOBJECT(GvHV(sv)) ||
+	     GvIO(sv) && SvOBJECT(GvIO(sv)) ||
+	     GvCV(sv) && SvOBJECT(GvCV(sv)) )
+	{
+	    DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
+	    SvREFCNT_dec(sv);
+	}
+	else if (GvSV(sv))
+	    do_clean_objs(GvSV(sv));
+    }
 }
 #endif
 
@@ -389,6 +400,10 @@ sv_free_arenas(void)
 	    Safefree((void *)sva);
     }
 
+    if (nice_chunk)
+	Safefree(nice_chunk);
+    nice_chunk = Nullch;
+    nice_chunk_size = 0;
     sv_arenaroot = 0;
     sv_root = 0;
 }
@@ -1891,8 +1906,11 @@ sv_setsv(SV *dstr, register SV *sstr)
 
     switch (stype) {
     case SVt_NULL:
-	(void)SvOK_off(dstr);
-	return;
+	if (dtype != SVt_PVGV) {
+	    (void)SvOK_off(dstr);
+	    return;
+	}
+	break;
     case SVt_IV:
 	if (dtype != SVt_IV && dtype < SVt_PVIV) {
 	    if (dtype < SVt_IV)
@@ -1939,7 +1957,6 @@ sv_setsv(SV *dstr, register SV *sstr)
 	if (dtype < SVt_PVNV)
 	    sv_upgrade(dstr, SVt_PVNV);
 	break;
-
     case SVt_PVAV:
     case SVt_PVHV:
     case SVt_PVCV:
@@ -1965,7 +1982,7 @@ sv_setsv(SV *dstr, register SV *sstr)
 		SvFAKE_on(dstr);	/* can coerce to non-glob */
 	    }
 	    /* ahem, death to those who redefine active sort subs */
-	    else if (curstack == sortstack
+	    else if (curstackinfo->si_type == SI_SORT
 		     && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr)))
 		croak("Can't redefine active sort subroutine %s",
 		      GvNAME(dstr));
@@ -1990,8 +2007,10 @@ sv_setsv(SV *dstr, register SV *sstr)
 		    goto glob_assign;
 	    }
 	}
-	if (dtype < stype)
-	    sv_upgrade(dstr, stype);
+	if (stype == SVt_PVLV)
+	    SvUPGRADE(dstr, SVt_PVNV);
+	else
+	    SvUPGRADE(dstr, stype);
     }
 
     sflags = SvFLAGS(sstr);
@@ -2054,7 +2073,7 @@ sv_setsv(SV *dstr, register SV *sstr)
 			    {
 				/* ahem, death to those who redefine
 				 * active sort subs */
-				if (curstack == sortstack &&
+				if (curstackinfo->si_type == SI_SORT &&
 				      sortcop == CvSTART(cv))
 				    croak(
 				    "Can't redefine active sort subroutine %s",
@@ -2062,9 +2081,14 @@ sv_setsv(SV *dstr, register SV *sstr)
 				if (cv_const_sv(cv))
 				    warn("Constant subroutine %s redefined",
 					 GvENAME((GV*)dstr));
-				else if (dowarn)
-				    warn("Subroutine %s redefined",
-					 GvENAME((GV*)dstr));
+				else if (dowarn) {
+				    if (!(CvGV(cv) && GvSTASH(CvGV(cv))
+					  && HvNAME(GvSTASH(CvGV(cv)))
+					  && strEQ(HvNAME(GvSTASH(CvGV(cv))),
+						   "autouse")))
+					warn("Subroutine %s redefined",
+					     GvENAME((GV*)dstr));
+				}
 			    }
 			    cv_ckproto(cv, (GV*)dstr,
 				       SvPOK(sref) ? SvPVX(sref) : Nullch);
@@ -2188,7 +2212,12 @@ sv_setsv(SV *dstr, register SV *sstr)
 	SvIVX(dstr) = SvIVX(sstr);
     }
     else {
-	(void)SvOK_off(dstr);
+	if (dtype == SVt_PVGV) {
+	    if (dowarn)
+		warn("Undefined value assigned to typeglob");
+	}
+	else
+	    (void)SvOK_off(dstr);
     }
     SvTAINT(dstr);
 }
@@ -2400,11 +2429,7 @@ sv_catpv_mg(register SV *sv, register char *ptr)
 }
 
 SV *
-#ifdef LEAKTEST
-newSV(I32 x, STRLEN len)
-#else
 newSV(STRLEN len)
-#endif
 {
     register SV *sv;
     
@@ -2712,6 +2737,7 @@ sv_replace(register SV *sv, register SV *nsv)
 void
 sv_clear(register SV *sv)
 {
+    HV* stash;
     assert(sv);
     assert(SvREFCNT(sv) == 0);
 
@@ -2720,7 +2746,6 @@ sv_clear(register SV *sv)
 	if (defstash) {		/* Still have a symbol table? */
 	    djSP;
 	    GV* destructor;
-	    HV* stash;
 	    SV ref;
 
 	    Zero(&ref, 1, SV);
@@ -2734,6 +2759,7 @@ sv_clear(register SV *sv)
 		destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
 		if (destructor) {
 		    ENTER;
+		    PUSHSTACK(SI_DESTROY);
 		    SvRV(&ref) = SvREFCNT_inc(sv);
 		    EXTEND(SP, 2);
 		    PUSHMARK(SP);
@@ -2742,6 +2768,7 @@ sv_clear(register SV *sv)
 		    perl_call_sv((SV*)GvCV(destructor),
 				 G_DISCARD|G_EVAL|G_KEEPERR);
 		    SvREFCNT(sv)--;
+		    POPSTACK();
 		    LEAVE;
 		}
 	    } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
@@ -2764,6 +2791,7 @@ sv_clear(register SV *sv)
     }
     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
 	mg_free(sv);
+    stash = NULL;
     switch (SvTYPE(sv)) {
     case SVt_PVIO:
 	if (IoIFP(sv) != PerlIO_stdin() &&
@@ -2789,7 +2817,11 @@ sv_clear(register SV *sv)
     case SVt_PVGV:
 	gp_free((GV*)sv);
 	Safefree(GvNAME(sv));
-	SvREFCNT_dec(GvSTASH(sv));
+	/* cannot decrease stash refcount yet, as we might recursively delete
+	   ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
+	   of stash until current sv is completely gone.
+	   -- JohnPC, 27 Mar 1998 */
+	stash = GvSTASH(sv);
 	/* FALL THROUGH */
     case SVt_PVLV:
     case SVt_PVMG:
@@ -2851,7 +2883,13 @@ sv_clear(register SV *sv)
 	break;
     case SVt_PVGV:
 	del_XPVGV(SvANY(sv));
-	break;
+	/* code duplication for increased performance. */
+	SvFLAGS(sv) &= SVf_BREAK;
+	SvFLAGS(sv) |= SVTYPEMASK;
+	/* decrease refcount of the stash that owns this GV, if any */
+	if (stash)
+	    SvREFCNT_dec(stash);
+	return; /* not break, SvFLAGS reset already happened */
     case SVt_PVBM:
 	del_XPVBM(SvANY(sv));
 	break;
@@ -3665,7 +3703,7 @@ sv_reset(register char *s, HV *stash)
 
     if (!*s) {		/* reset ?? searches */
 	for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
-	    pm->op_pmflags &= ~PMf_USED;
+	    pm->op_pmdynflags &= ~PMdf_USED;
 	}
 	return;
     }
@@ -4085,6 +4123,10 @@ sv_unglob(SV *sv)
     SvFAKE_off(sv);
     if (GvGP(sv))
 	gp_free((GV*)sv);
+    if (GvSTASH(sv)) {
+	SvREFCNT_dec(GvSTASH(sv));
+	GvSTASH(sv) = Nullhv;
+    }
     sv_unmagic(sv, '*');
     Safefree(GvNAME(sv));
     GvMULTI_off(sv);
@@ -4572,6 +4614,8 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs,
 	    switch (base) {
 		unsigned dig;
 	    case 16:
+		if (!uv)
+		    alt = FALSE;
 		p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
 		do {
 		    dig = uv & 15;
@@ -4598,8 +4642,12 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs,
 		break;
 	    }
 	    elen = (ebuf + sizeof ebuf) - eptr;
-	    if (has_precis && precis > elen)
-		zeros = precis - elen;
+	    if (has_precis) {
+		if (precis > elen)
+		    zeros = precis - elen;
+		else if (precis == 0 && elen == 1 && *eptr == '0')
+		    elen = 0;
+	    }
 	    break;
 
 	    /* FLOATING POINT */
@@ -4993,7 +5041,8 @@ sv_dump(SV *sv)
     case SVt_PVGV:
 	PerlIO_printf(Perl_debug_log, "  NAME = \"%s\"\n", GvNAME(sv));
 	PerlIO_printf(Perl_debug_log, "  NAMELEN = %ld\n", (long)GvNAMELEN(sv));
-	PerlIO_printf(Perl_debug_log, "  STASH = \"%s\"\n", HvNAME(GvSTASH(sv)));
+	PerlIO_printf(Perl_debug_log, "  STASH = \"%s\"\n",
+	    SvTYPE(GvSTASH(sv)) == SVt_PVHV ? HvNAME(GvSTASH(sv)) : "(deleted)");
 	PerlIO_printf(Perl_debug_log, "  GP = 0x%lx\n", (long)GvGP(sv));
 	PerlIO_printf(Perl_debug_log, "    SV = 0x%lx\n", (long)GvSV(sv));
 	PerlIO_printf(Perl_debug_log, "    REFCNT = %ld\n", (long)GvREFCNT(sv));