X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=fc89183c775c6f5d4bf3e79b96f3c65d6801be05;hb=360321b398f5e797c408b6d6c60b7da3cca5e324;hp=d92d82acb779c2c422526244bfe15f33dcbc0d10;hpb=087424585c6baf6c4e26990d64c6fb9f01b16a53;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/sv.c b/sv.c
index d92d82a..fc89183 100644
--- a/sv.c
+++ b/sv.c
@@ -188,11 +188,7 @@ Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
 }
 
 #ifdef DEBUG_LEAKING_SCALARS
-#  ifdef NETWARE
-#    define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
-#  else
-#    define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
-#  endif
+#  define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
 #else
 #  define FREE_SV_DEBUG_FILE(sv)
 #endif
@@ -230,7 +226,7 @@ S_more_sv(pTHX)
     }
     else {
 	char *chunk;                /* must use New here to match call to */
-	New(704,chunk,PERL_ARENA_SIZE,char);   /* Safefree() in sv_free_arenas()     */
+	Newx(chunk,PERL_ARENA_SIZE,char);   /* Safefree() in sv_free_arenas()     */
 	sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
     }
     uproot_SV(sv);
@@ -260,11 +256,7 @@ S_new_SV(pTHX)
         (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
     sv->sv_debug_inpad = 0;
     sv->sv_debug_cloned = 0;
-#  ifdef NETWARE
     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
-#  else
-    sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
-#  endif
     
     return sv;
 }
@@ -437,18 +429,19 @@ Perl_sv_report_used(pTHX)
 static void
 do_clean_objs(pTHX_ SV *ref)
 {
-    SV* target;
-
-    if (SvROK(ref) && SvOBJECT(target = SvRV(ref))) {
-	DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
-	if (SvWEAKREF(ref)) {
-	    sv_del_backref(target, ref);
-	    SvWEAKREF_off(ref);
-	    SvRV_set(ref, NULL);
-	} else {
-	    SvROK_off(ref);
-	    SvRV_set(ref, NULL);
-	    SvREFCNT_dec(target);
+    if (SvROK(ref)) {
+	SV * const target = SvRV(ref);
+	if (SvOBJECT(target)) {
+	    DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
+	    if (SvWEAKREF(ref)) {
+		sv_del_backref(target, ref);
+		SvWEAKREF_off(ref);
+		SvRV_set(ref, NULL);
+	    } else {
+		SvROK_off(ref);
+		SvRV_set(ref, NULL);
+		SvREFCNT_dec(target);
+	    }
 	}
     }
 
@@ -1087,7 +1080,7 @@ S_more_bodies (pTHX_ void **arena_root, void **root, size_t size)
     char *start;
     const char *end;
     const size_t count = PERL_ARENA_SIZE/size;
-    New(0, start, count*size, char);
+    Newx(start, count*size, char);
     *((void **) start) = *arena_root;
     *arena_root = (void *)start;
 
@@ -1112,18 +1105,7 @@ S_more_bodies (pTHX_ void **arena_root, void **root, size_t size)
 
 /* grab a new thing from the free list, allocating more if necessary */
 
-STATIC void *
-S_new_body(pTHX_ void **arena_root, void **root, size_t size)
-{
-    void *xpv;
-    LOCK_SV_MUTEX;
-    xpv = *root ? *root : S_more_bodies(aTHX_ arena_root, root, size);
-    *root = *(void**)xpv;
-    UNLOCK_SV_MUTEX;
-    return xpv;
-}
-
-/* and an inline version  */
+/* 1st, the inline version  */
 
 #define new_body_inline(xpv, arena_root, root, size) \
     STMT_START { \
@@ -1134,6 +1116,16 @@ S_new_body(pTHX_ void **arena_root, void **root, size_t size)
 	UNLOCK_SV_MUTEX; \
     } STMT_END
 
+/* now use the inline version in the proper function */
+
+STATIC void *
+S_new_body(pTHX_ void **arena_root, void **root, size_t size)
+{
+    void *xpv;
+    new_body_inline(xpv, arena_root, root, size);
+    return xpv;
+}
+
 /* return a thing to the free list */
 
 #define del_body(thing, root)			\
@@ -1861,7 +1853,7 @@ S_not_a_number(pTHX_ SV *sv)
           pv = sv_uni_display(dsv, sv, 10, 0);
      } else {
 	  char *d = tmpbuf;
-	  char *limit = tmpbuf + sizeof(tmpbuf) - 8;
+	  const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
 	  /* each *s can expand to 4 chars + "...\0",
 	     i.e. need room for 8 chars */
 	
@@ -2114,7 +2106,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
 	    return asIV(sv);
 	if (!SvROK(sv)) {
 	    if (!(SvFLAGS(sv) & SVs_PADTMP)) {
-		if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+		if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
 		    report_uninit(sv);
 	    }
 	    return 0;
@@ -2122,11 +2114,13 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
     }
     if (SvTHINKFIRST(sv)) {
 	if (SvROK(sv)) {
-	  SV* tmpstr;
-          if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
-                (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
-	      return SvIV(tmpstr);
-	  return PTR2IV(SvRV(sv));
+	    if (SvAMAGIC(sv)) {
+		SV * const tmpstr=AMG_CALLun(sv,numer);
+		if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+		    return SvIV(tmpstr);
+		}
+	    }
+	    return PTR2IV(SvRV(sv));
 	}
 	if (SvIsCOW(sv)) {
 	    sv_force_normal_flags(sv, 0);
@@ -2374,7 +2368,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
 #endif /* NV_PRESERVES_UV */
 	}
     } else  {
-	if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+	if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
 	    report_uninit(sv);
 	if (SvTYPE(sv) < SVt_IV)
 	    /* Typically the caller expects that sv_any is not NULL now.  */
@@ -2422,7 +2416,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
 	    return asUV(sv);
 	if (!SvROK(sv)) {
 	    if (!(SvFLAGS(sv) & SVs_PADTMP)) {
-		if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+		if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
 		    report_uninit(sv);
 	    }
 	    return 0;
@@ -2663,7 +2657,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
     }
     else  {
 	if (!(SvFLAGS(sv) & SVs_PADTMP)) {
-	    if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+	    if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
 		report_uninit(sv);
 	}
 	if (SvTYPE(sv) < SVt_IV)
@@ -2697,7 +2691,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
 	if (SvNOKp(sv))
 	    return SvNVX(sv);
 	if (SvPOKp(sv) && SvLEN(sv)) {
-	    if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
+	    if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
 		!grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
 		not_a_number(sv);
 	    return Atof(SvPVX_const(sv));
@@ -2710,7 +2704,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
 	}	
         if (!SvROK(sv)) {
 	    if (!(SvFLAGS(sv) & SVs_PADTMP)) {
-		if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+		if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
 		    report_uninit(sv);
 	    }
             return (NV)0;
@@ -2777,7 +2771,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
     else if (SvPOKp(sv) && SvLEN(sv)) {
 	UV value;
 	const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
-	if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
+	if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
 	    not_a_number(sv);
 #ifdef NV_PRESERVES_UV
 	if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
@@ -2859,7 +2853,7 @@ Perl_sv_2nv(pTHX_ register SV *sv)
 #endif /* NV_PRESERVES_UV */
     }
     else  {
-	if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+	if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
 	    report_uninit(sv);
 	if (SvTYPE(sv) < SVt_NV)
 	    /* Typically the caller expects that sv_any is not NULL now.  */
@@ -2957,10 +2951,10 @@ Perl_sv_2pv_nolen(pTHX_ register SV *sv)
  */
 
 static char *
-uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
+S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
 {
     char *ptr = buf + TYPE_CHARS(UV);
-    char *ebuf = ptr;
+    char * const ebuf = ptr;
     int sign;
 
     if (is_uv)
@@ -3044,7 +3038,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
 	}
         if (!SvROK(sv)) {
 	    if (!(SvFLAGS(sv) & SVs_PADTMP)) {
-		if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+		if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
 		    report_uninit(sv);
 	    }
 	    if (lp)
@@ -3152,7 +3146,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
                                 }
                             }
 
-			    New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
+			    Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
 			    Copy("(?", mg->mg_ptr, 2, char);
 			    Copy(reflags, mg->mg_ptr+2, left, char);
 			    Copy(":", mg->mg_ptr+left+2, 1, char);
@@ -3269,8 +3263,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
 #endif
     }
     else {
-	if (ckWARN(WARN_UNINITIALIZED)
-	    && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+	if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
 	    report_uninit(sv);
 	if (lp)
 	*lp = 0;
@@ -3280,7 +3273,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
 	return (char *)"";
     }
     {
-	STRLEN len = s - SvPVX_const(sv);
+	const STRLEN len = s - SvPVX_const(sv);
 	if (lp) 
 	    *lp = len;
 	SvCUR_set(sv, len);
@@ -3430,7 +3423,7 @@ char *
 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
 {
     sv_utf8_upgrade(sv);
-    return SvPV(sv,*lp);
+    return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
 }
 
 /*
@@ -3445,8 +3438,7 @@ sv_true() or its macro equivalent.
 bool
 Perl_sv_2bool(pTHX_ register SV *sv)
 {
-    if (SvGMAGICAL(sv))
-	mg_get(sv);
+    SvGETMAGIC(sv);
 
     if (!SvOK(sv))
 	return 0;
@@ -3922,7 +3914,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
     if (sflags & SVf_ROK) {
 	if (dtype >= SVt_PV) {
 	    if (dtype == SVt_PVGV) {
-		SV *sref = SvREFCNT_inc(SvRV(sstr));
+		SV * const sref = SvREFCNT_inc(SvRV(sstr));
 		SV *dref = 0;
 		const int intro = GvINTRO(dstr);
 
@@ -3976,7 +3968,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
 		    else
 			dref = (SV*)GvCV(dstr);
 		    if (GvCV(dstr) != (CV*)sref) {
-			CV* cv = GvCV(dstr);
+			CV* const cv = GvCV(dstr);
 			if (cv) {
 			    if (!GvCVGEN((GV*)dstr) &&
 				(CvROOT(cv) || CvXSUB(cv)))
@@ -4507,7 +4499,7 @@ S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
 {
     if (len) { /* this SV was SvIsCOW_normal(sv) */
          /* we need to find the SV pointing to us.  */
-        SV *current = SV_COW_NEXT_SV(after);
+        SV * const current = SV_COW_NEXT_SV(after);
 
         if (current == sv) {
             /* The SV we point to points back to us (there were only two of us
@@ -4578,7 +4570,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
             }
             SvFAKE_off(sv);
             SvREADONLY_off(sv);
-            /* This SV doesn't own the buffer, so need to New() a new one:  */
+            /* This SV doesn't own the buffer, so need to Newx() a new one:  */
             SvPV_set(sv, (char*)0);
             SvLEN_set(sv, 0);
             if (flags & SV_COW_DROP_PV) {
@@ -4609,7 +4601,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
 	    SvPV_set(sv, Nullch);
 	    SvLEN_set(sv, 0);
 	    SvGROW(sv, len + 1);
-	    Move(pvx,SvPVX_const(sv),len,char);
+	    Move(pvx,SvPVX(sv),len,char);
 	    *SvEND(sv) = '\0';
 	    unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
 	}
@@ -4668,7 +4660,7 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
 	    const char *pvx = SvPVX_const(sv);
 	    const STRLEN len = SvCUR(sv);
 	    SvGROW(sv, len + 1);
-	    Move(pvx,SvPVX_const(sv),len,char);
+	    Move(pvx,SvPVX(sv),len,char);
 	    *SvEND(sv) = '\0';
 	}
 	SvIV_set(sv, 0);
@@ -4917,7 +4909,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
     if (SvTYPE(sv) < SVt_PVMG) {
 	SvUPGRADE(sv, SVt_PVMG);
     }
-    Newz(702,mg, 1, MAGIC);
+    Newxz(mg, 1, MAGIC);
     mg->mg_moremagic = SvMAGIC(sv);
     SvMAGIC_set(sv, mg);
 
@@ -4996,7 +4988,7 @@ to add more than one instance of the same 'how'.
 void
 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
 {
-    const MGVTBL *vtable = 0;
+    const MGVTBL *vtable;
     MAGIC* mg;
 
 #ifdef PERL_OLD_COPY_ON_WRITE
@@ -5075,7 +5067,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
 	vtable = &PL_vtbl_nkeys;
 	break;
     case PERL_MAGIC_dbfile:
-	vtable = 0;
+	vtable = NULL;
 	break;
     case PERL_MAGIC_dbline:
 	vtable = &PL_vtbl_dbline;
@@ -5114,7 +5106,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     case PERL_MAGIC_rhash:
     case PERL_MAGIC_symtab:
     case PERL_MAGIC_vstring:
-	vtable = 0;
+	vtable = NULL;
 	break;
     case PERL_MAGIC_utf8:
 	vtable = &PL_vtbl_utf8;
@@ -5142,13 +5134,14 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
 	/* Useful for attaching extension internal data to perl vars.	*/
 	/* Note that multiple extensions may clash if magical scalars	*/
 	/* etc holding private data from one are passed to another.	*/
+	vtable = NULL;
 	break;
     default:
 	Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
     }
 
     /* Rest of work is done else where */
-    mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
+    mg = sv_magicext(sv,obj,how,vtable,name,namlen);
 
     switch (how) {
     case PERL_MAGIC_taint:
@@ -5410,8 +5403,10 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
 {
     const U32 refcnt = SvREFCNT(sv);
     SV_CHECK_THINKFIRST_COW_DROP(sv);
-    if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
-	Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
+    if (SvREFCNT(nsv) != 1) {
+	Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
+		   UVuf " != 1)", (UV) SvREFCNT(nsv));
+    }
     if (SvMAGICAL(sv)) {
 	if (SvMAGICAL(nsv))
 	    mg_free(nsv);
@@ -5868,7 +5863,7 @@ S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
 	if ((*mgp)->mg_ptr)
 	    *cachep = (STRLEN *) (*mgp)->mg_ptr;
 	else {
-	    Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
+	    Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
 	    (*mgp)->mg_ptr = (char *) *cachep;
 	}
 	assert(*cachep);
@@ -6190,7 +6185,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
 	    assert(mg);
 
 	    if (!mg->mg_ptr) {
-		Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
+		Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
 		mg->mg_ptr = (char *) cache;
 	    }
 	    assert(cache);
@@ -6789,7 +6784,7 @@ thats_really_all_folks:
        /*The big, slow, and stupid way. */
 #ifdef USE_HEAP_INSTEAD_OF_STACK	/* Even slower way. */
 	STDCHAR *buf = 0;
-	New(0, buf, 8192, STDCHAR);
+	Newx(buf, 8192, STDCHAR);
 	assert(buf);
 #else
 	STDCHAR buf[8192];
@@ -6797,7 +6792,7 @@ thats_really_all_folks:
 
 screamer2:
 	if (rslen) {
-            const register STDCHAR *bpe = buf + sizeof(buf);
+            register const STDCHAR *bpe = buf + sizeof(buf);
 	    bp = buf;
 	    while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
 		; /* keep reading */
@@ -6878,8 +6873,7 @@ Perl_sv_inc(pTHX_ register SV *sv)
 
     if (!sv)
 	return;
-    if (SvGMAGICAL(sv))
-	mg_get(sv);
+    SvGETMAGIC(sv);
     if (SvTHINKFIRST(sv)) {
 	if (SvIsCOW(sv))
 	    sv_force_normal_flags(sv, 0);
@@ -7034,8 +7028,7 @@ Perl_sv_dec(pTHX_ register SV *sv)
 
     if (!sv)
 	return;
-    if (SvGMAGICAL(sv))
-	mg_get(sv);
+    SvGETMAGIC(sv);
     if (SvTHINKFIRST(sv)) {
 	if (SvIsCOW(sv))
 	    sv_force_normal_flags(sv, 0);
@@ -7067,7 +7060,7 @@ Perl_sv_dec(pTHX_ register SV *sv)
 	    }
 	    else {
 		(void)SvIOK_only_UV(sv);
-		SvUV_set(sv, SvUVX(sv) + 1);
+		SvUV_set(sv, SvUVX(sv) - 1);
 	    }	
 	} else {
 	    if (SvIVX(sv) == IV_MIN)
@@ -7532,7 +7525,7 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash)
 	return;
 
     if (!*s) {		/* reset ?? searches */
-	MAGIC *mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
+	MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
 	if (mg) {
 	    PMOP *pm = (PMOP *) mg->mg_obj;
 	    while (pm) {
@@ -7688,10 +7681,9 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
 	goto fix_gv;
 
     default:
-	if (SvGMAGICAL(sv))
-	    mg_get(sv);
+	SvGETMAGIC(sv);
 	if (SvROK(sv)) {
-	    SV **sp = &sv;		/* Used in tryAMAGICunDEREF macro. */
+	    SV * const *sp = &sv;	/* Used in tryAMAGICunDEREF macro. */
 	    tryAMAGICunDEREF(to_cv);
 
 	    sv = SvRV(sv);
@@ -7752,8 +7744,8 @@ Perl_sv_true(pTHX_ register SV *sv)
     if (!sv)
 	return 0;
     if (SvPOK(sv)) {
-	const register XPV* tXpv;
-	if ((tXpv = (XPV*)SvANY(sv)) &&
+	register const XPV* const tXpv = (XPV*)SvANY(sv);
+	if (tXpv &&
 		(tXpv->xpv_cur > 1 ||
 		(tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
 	    return 1;
@@ -7940,7 +7932,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
 		sv_unref(sv);
 	    SvUPGRADE(sv, SVt_PV);		/* Never FALSE */
 	    SvGROW(sv, len + 1);
-	    Move(s,SvPVX_const(sv),len,char);
+	    Move(s,SvPVX(sv),len,char);
 	    SvCUR_set(sv, len);
 	    *SvEND(sv) = '\0';
 	}
@@ -8122,8 +8114,7 @@ Perl_sv_isobject(pTHX_ SV *sv)
 {
     if (!sv)
 	return 0;
-    if (SvGMAGICAL(sv))
-	mg_get(sv);
+    SvGETMAGIC(sv);
     if (!SvROK(sv))
 	return 0;
     sv = (SV*)SvRV(sv);
@@ -8148,8 +8139,7 @@ Perl_sv_isa(pTHX_ SV *sv, const char *name)
     const char *hvname;
     if (!sv)
 	return 0;
-    if (SvGMAGICAL(sv))
-	mg_get(sv);
+    SvGETMAGIC(sv);
     if (!SvROK(sv))
 	return 0;
     sv = (SV*)SvRV(sv);
@@ -8488,7 +8478,7 @@ bool
 Perl_sv_tainted(pTHX_ SV *sv)
 {
     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
-	MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
+	const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
 	if (mg && (mg->mg_len & 1) )
 	    return TRUE;
     }
@@ -8817,6 +8807,11 @@ Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
 =cut
 */
 
+
+#define VECTORIZE_ARGS	vecsv = va_arg(*args, SV*);\
+			vecstr = (U8*)SvPV_const(vecsv,veclen);\
+			vec_utf8 = DO_UTF8(vecsv);
+
 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
 
 void
@@ -8844,30 +8839,28 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
     /* no matter what, this is a string now */
     (void)SvPV_force(sv, origlen);
 
-    /* special-case "", "%s", and "%-p" (SVf) */
+    /* special-case "", "%s", and "%-p" (SVf - see below) */
     if (patlen == 0)
 	return;
     if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
-	    if (args) {
-		const char * const s = va_arg(*args, char*);
-		sv_catpv(sv, s ? s : nullstr);
-	    }
-	    else if (svix < svmax) {
-		sv_catsv(sv, *svargs);
-		if (DO_UTF8(*svargs))
-		    SvUTF8_on(sv);
-	    }
-	    return;
+	if (args) {
+	    const char * const s = va_arg(*args, char*);
+	    sv_catpv(sv, s ? s : nullstr);
+	}
+	else if (svix < svmax) {
+	    sv_catsv(sv, *svargs);
+	    if (DO_UTF8(*svargs))
+		SvUTF8_on(sv);
+	}
+	return;
     }
-    if (patlen == 3 && pat[0] == '%' &&
-	pat[1] == '-' && pat[2] == 'p') {
-	    if (args) {
-		argsv = va_arg(*args, SV*);
-		sv_catsv(sv, argsv);
-		if (DO_UTF8(argsv))
-		    SvUTF8_on(sv);
-		return;
-	    }
+    if (args && patlen == 3 && pat[0] == '%' &&
+		pat[1] == '-' && pat[2] == 'p') {
+	argsv = va_arg(*args, SV*);
+	sv_catsv(sv, argsv);
+	if (DO_UTF8(argsv))
+	    SvUTF8_on(sv);
+	return;
     }
 
 #ifndef USE_LONG_DOUBLE
@@ -8989,8 +8982,60 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	\d+|\*(\d+\$)?     width using optional (optionally specified) arg
 	\.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
 	[hlqLV]            size
-    [%bcdefginopsux_DFOUX] format (mandatory)
+    [%bcdefginopsuxDFOUX] format (mandatory)
+*/
+
+	if (args) {
+/*  
+	As of perl5.9.3, printf format checking is on by default.
+	Internally, perl uses %p formats to provide an escape to
+	some extended formatting.  This block deals with those
+	extensions: if it does not match, (char*)q is reset and
+	the normal format processing code is used.
+
+	Currently defined extensions are:
+		%p		include pointer address (standard)	
+		%-p	(SVf)	include an SV (previously %_)
+		%-<num>p	include an SV with precision <num>	
+		%1p	(VDf)	include a v-string (as %vd)
+		%<num>p		reserved for future extensions
+
+	Robin Barker 2005-07-14
 */
+ 	    char* r = q; 
+	    bool sv = FALSE;	
+	    STRLEN n = 0;
+	    if (*q == '-')
+		sv = *q++;
+	    EXPECT_NUMBER(q, n);
+	    if (*q++ == 'p') {
+		if (sv) {			/* SVf */
+		    if (n) {
+			precis = n;
+			has_precis = TRUE;
+		    }
+		    argsv = va_arg(*args, SV*);
+		    eptr = SvPVx_const(argsv, elen);
+		    if (DO_UTF8(argsv))
+			is_utf8 = TRUE;
+		    goto string;
+		}
+#if vdNUMBER
+		else if (n == vdNUMBER) {	/* VDf */
+		    vectorize = TRUE;
+		    VECTORIZE_ARGS
+		    goto format_vd;
+	  	}
+#endif
+		else if (n) {
+		    if (ckWARN_d(WARN_INTERNAL))
+			Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+			"internal %%<num>p might conflict with future printf extensions");
+		}
+	    }
+	    q = r; 
+	}
+
 	if (EXPECT_NUMBER(q, width)) {
 	    if (*q == '$') {
 		++q;
@@ -9051,9 +9096,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	}
 
 	if (!asterisk)
+	{
 	    if( *q == '0' )
 		fill = *q++;
 	    EXPECT_NUMBER(q, width);
+	}
 
 	if (vectorize) {
 	    if (vectorarg) {
@@ -9067,9 +9114,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		    is_utf8 = TRUE;
 	    }
 	    if (args) {
-		vecsv = va_arg(*args, SV*);
-		vecstr = (U8*)SvPV_const(vecsv,veclen);
-		vec_utf8 = DO_UTF8(vecsv);
+		VECTORIZE_ARGS
 	    }
 	    else if (efix ? efix <= svmax : svix < svmax) {
 		vecsv = svargs[efix ? efix-1 : svix++];
@@ -9253,21 +9298,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    /* INTEGERS */
 
 	case 'p':
-	    if (left && args) {		/* SVf */
-		left = FALSE;
-		if (width) {
-		    precis = width;
-		    has_precis = TRUE;
-		    width = 0;
-		}
-		if (vectorize)
-		    goto unknown;
-		argsv = va_arg(*args, SV*);
-		eptr = SvPVx_const(argsv, elen);
-		if (DO_UTF8(argsv))
-		    is_utf8 = TRUE;
-		goto string;
-	    }
 	    if (alt || vectorize)
 		goto unknown;
 	    uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
@@ -9283,6 +9313,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    /* FALL THROUGH */
 	case 'd':
 	case 'i':
+#if vdNUMBER
+	format_vd:
+#endif
 	    if (vectorize) {
 		STRLEN ulen;
 		if (!veclen)
@@ -9599,7 +9632,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    if (PL_efloatsize < need) {
 		Safefree(PL_efloatbuf);
 		PL_efloatsize = need + 20; /* more fudge */
-		New(906, PL_efloatbuf, PL_efloatsize, char);
+		Newx(PL_efloatbuf, PL_efloatsize, char);
 		PL_efloatbuf[0] = '\0';
 	    }
 
@@ -9691,8 +9724,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
 	default:
       unknown:
-	    if (!args && ckWARN(WARN_PRINTF) &&
-		  (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
+	    if (!args
+		&& (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
+		&& ckWARN(WARN_PRINTF))
+	    {
 		SV *msg = sv_newmortal();
 		Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
 			  (PL_op->op_type == OP_PRTF) ? "" : "s");
@@ -9857,15 +9892,15 @@ Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
     len = r->offsets[0];
     npar = r->nparens+1;
 
-    Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
+    Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
     Copy(r->program, ret->program, len+1, regnode);
 
-    New(0, ret->startp, npar, I32);
+    Newx(ret->startp, npar, I32);
     Copy(r->startp, ret->startp, npar, I32);
-    New(0, ret->endp, npar, I32);
+    Newx(ret->endp, npar, I32);
     Copy(r->startp, ret->startp, npar, I32);
 
-    New(0, ret->substrs, 1, struct reg_substr_data);
+    Newx(ret->substrs, 1, struct reg_substr_data);
     for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
 	s->min_offset = r->substrs->data[i].min_offset;
 	s->max_offset = r->substrs->data[i].max_offset;
@@ -9879,9 +9914,9 @@ Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
         const int count = r->data->count;
 	int i;
 
-	Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
+	Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
 		char, struct reg_data);
-	New(0, d->what, count, U8);
+	Newx(d->what, count, U8);
 
 	d->count = count;
 	for (i = 0; i < count; i++) {
@@ -9897,7 +9932,7 @@ Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
 		break;
 	    case 'f':
 		/* This is cheating. */
-		New(0, d->data[i], 1, struct regnode_charclass_class);
+		Newx(d->data[i], 1, struct regnode_charclass_class);
 		StructCopy(r->data->data[i], d->data[i],
 			    struct regnode_charclass_class);
 		ret->regstclass = (regnode*)d->data[i];
@@ -9928,7 +9963,7 @@ Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
     else
 	ret->data = NULL;
 
-    New(0, ret->offsets, 2*len+1, U32);
+    Newx(ret->offsets, 2*len+1, U32);
     Copy(r->offsets, ret->offsets, 2*len+1, U32);
 
     ret->precomp        = SAVEPVN(r->precomp, r->prelen);
@@ -10002,7 +10037,7 @@ Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
 	return ret;
 
     /* create anew and remember what it is */
-    Newz(0, ret, 1, GP);
+    Newxz(ret, 1, GP);
     ptr_table_store(PL_ptr_table, gp, ret);
 
     /* clone */
@@ -10036,7 +10071,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
 
     for (; mg; mg = mg->mg_moremagic) {
 	MAGIC *nmg;
-	Newz(0, nmg, 1, MAGIC);
+	Newxz(nmg, 1, MAGIC);
 	if (mgprev)
 	    mgprev->mg_moremagic = nmg;
 	else
@@ -10100,10 +10135,10 @@ PTR_TBL_t *
 Perl_ptr_table_new(pTHX)
 {
     PTR_TBL_t *tbl;
-    Newz(0, tbl, 1, PTR_TBL_t);
+    Newxz(tbl, 1, PTR_TBL_t);
     tbl->tbl_max	= 511;
     tbl->tbl_items	= 0;
-    Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
+    Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
     return tbl;
 }
 
@@ -10134,27 +10169,27 @@ Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
 /* add a new entry to a pointer-mapping table */
 
 void
-Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldv, void *newv)
+Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
 {
     PTR_TBL_ENT_t *tblent, **otblent;
     /* XXX this may be pessimal on platforms where pointers aren't good
      * hash values e.g. if they grow faster in the most significant
      * bits */
-    const UV hash = PTR_TABLE_HASH(oldv);
+    const UV hash = PTR_TABLE_HASH(oldsv);
     bool empty = 1;
 
     assert(tbl);
     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
     for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
-	if (tblent->oldval == oldv) {
-	    tblent->newval = newv;
+	if (tblent->oldval == oldsv) {
+	    tblent->newval = newsv;
 	    return;
 	}
     }
     new_body_inline(tblent, (void**)&PL_pte_arenaroot, (void**)&PL_pte_root,
 		    sizeof(struct ptr_tbl_ent));
-    tblent->oldval = oldv;
-    tblent->newval = newv;
+    tblent->oldval = oldsv;
+    tblent->newval = newsv;
     tblent->next = *otblent;
     *otblent = tblent;
     tbl->tbl_items++;
@@ -10310,8 +10345,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
         if(SvTYPE(sstr) == SVt_PVHV &&
 	   (hvname = HvNAME_get(sstr))) {
 	    /** don't clone stashes if they already exist **/
-	    HV* old_stash = gv_stashpv(hvname,0);
-	    return (SV*) old_stash;
+	    return (SV*)gv_stashpv(hvname,0);
         }
     }
 
@@ -10548,7 +10582,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
 		    SSize_t items = AvFILLp((AV*)sstr) + 1;
 
 		    src_ary = AvARRAY((AV*)sstr);
-		    Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
+		    Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
 		    ptr_table_store(PL_ptr_table, src_ary, dst_ary);
 		    SvPV_set(dstr, (char*)dst_ary);
 		    AvALLOC((AV*)dstr) = dst_ary;
@@ -10580,13 +10614,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
 			XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
 			XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
 			char *darray;
-			New(0, darray,
-			    PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
+			Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
 			    + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
 			    char);
 			HvARRAY(dstr) = (HE**)darray;
 			while (i <= sxhv->xhv_max) {
-			    HE *source = HvARRAY(sstr)[i];
+			    const HE *source = HvARRAY(sstr)[i];
 			    HvARRAY(dstr)[i] = source
 				? he_dup(source, sharekeys, param) : 0;
 			    ++i;
@@ -10669,7 +10702,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
 	return ncxs;
 
     /* create anew and remember what it is */
-    Newz(56, ncxs, max + 1, PERL_CONTEXT);
+    Newxz(ncxs, max + 1, PERL_CONTEXT);
     ptr_table_store(PL_ptr_table, cxs, ncxs);
 
     while (ix >= 0) {
@@ -10759,7 +10792,7 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
 	return nsi;
 
     /* create anew and remember what it is */
-    Newz(56, nsi, 1, PERL_SI);
+    Newxz(nsi, 1, PERL_SI);
     ptr_table_store(PL_ptr_table, si, nsi);
 
     nsi->si_stack	= av_dup_inc(si->si_stack, param);
@@ -10843,7 +10876,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
     void (*dptr) (void*);
     void (*dxptr) (pTHX_ void*);
 
-    Newz(54, nss, max, ANY);
+    Newxz(nss, max, ANY);
 
     while (ix > 0) {
 	I32 i = POPINT(ss,ix);
@@ -11375,6 +11408,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     param->stashes      = newAV();  /* Setup array of objects to call clone on */
 
+    /* Set tainting stuff before PerlIO_debug can possibly get called */
+    PL_tainting		= proto_perl->Itainting;
+    PL_taint_warn	= proto_perl->Itaint_warn;
+
 #ifdef PERLIO_LAYERS
     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
     PerlIO_clone(aTHX_ proto_perl, param);
@@ -11419,6 +11456,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_statusvalue	= proto_perl->Istatusvalue;
 #ifdef VMS
     PL_statusvalue_vms	= proto_perl->Istatusvalue_vms;
+#else
+    PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
 #endif
     PL_encoding		= sv_dup(proto_perl->Iencoding, param);
 
@@ -11496,8 +11535,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_fdpid		= av_dup_inc(proto_perl->Ifdpid, param);
 
     /* internal state */
-    PL_tainting		= proto_perl->Itainting;
-    PL_taint_warn       = proto_perl->Itaint_warn;
     PL_maxo		= proto_perl->Imaxo;
     if (proto_perl->Iop_mask)
 	PL_op_mask	= SAVEPVN(proto_perl->Iop_mask, PL_maxo);
@@ -11533,7 +11570,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     /* interpreter atexit processing */
     PL_exitlistlen	= proto_perl->Iexitlistlen;
     if (PL_exitlistlen) {
-	New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
+	Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
 	Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
     }
     else
@@ -11750,15 +11787,15 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_bitcount		= Nullch;	/* reinits on demand */
 
     if (proto_perl->Ipsig_pend) {
-	Newz(0, PL_psig_pend, SIG_SIZE, int);
+	Newxz(PL_psig_pend, SIG_SIZE, int);
     }
     else {
 	PL_psig_pend	= (int*)NULL;
     }
 
     if (proto_perl->Ipsig_ptr) {
-	Newz(0, PL_psig_ptr,  SIG_SIZE, SV*);
-	Newz(0, PL_psig_name, SIG_SIZE, SV*);
+	Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
+	Newxz(PL_psig_name, SIG_SIZE, SV*);
 	for (i = 1; i < SIG_SIZE; i++) {
 	    PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
 	    PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
@@ -11776,7 +11813,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 	PL_tmps_ix		= proto_perl->Ttmps_ix;
 	PL_tmps_max		= proto_perl->Ttmps_max;
 	PL_tmps_floor		= proto_perl->Ttmps_floor;
-	Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
+	Newxz(PL_tmps_stack, PL_tmps_max, SV*);
 	i = 0;
 	while (i <= PL_tmps_ix) {
 	    PL_tmps_stack[i]	= sv_dup_inc(proto_perl->Ttmps_stack[i], param);
@@ -11785,7 +11822,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
 	/* next PUSHMARK() sets *(PL_markstack_ptr+1) */
 	i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
-	Newz(54, PL_markstack, i, I32);
+	Newxz(PL_markstack, i, I32);
 	PL_markstack_max	= PL_markstack + (proto_perl->Tmarkstack_max
 						  - proto_perl->Tmarkstack);
 	PL_markstack_ptr	= PL_markstack + (proto_perl->Tmarkstack_ptr
@@ -11797,7 +11834,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 	 * NOTE: unlike the others! */
 	PL_scopestack_ix	= proto_perl->Tscopestack_ix;
 	PL_scopestack_max	= proto_perl->Tscopestack_max;
-	Newz(54, PL_scopestack, PL_scopestack_max, I32);
+	Newxz(PL_scopestack, PL_scopestack_max, I32);
 	Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
 
 	/* NOTE: si_dup() looks at PL_markstack */
@@ -11817,7 +11854,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 	 * NOTE: unlike the others! */
 	PL_savestack_ix		= proto_perl->Tsavestack_ix;
 	PL_savestack_max	= proto_perl->Tsavestack_max;
-	/*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
+	/*Newxz(PL_savestack, PL_savestack_max, ANY);*/
 	PL_savestack		= ss_dup(proto_perl, param);
     }
     else {