X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=2f5ea0b7b7a2d5cd0074400dd5c87310ea5f0d68;hb=6b49d2665cf5b4cee8758bc654f9290f3855049e;hp=52bf820a0b0aff0bacd97fa54e34275c0fe0693c;hpb=9a54186f86fa89533f9a21879513bc2ce58df609;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/sv.c b/sv.c
index 52bf820..2f5ea0b 100644
--- a/sv.c
+++ b/sv.c
@@ -107,7 +107,7 @@ Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
     SV* sva = (SV*)ptr;
     register SV* sv;
     register SV* svend;
-    Zero(sva, size, char);
+    Zero(ptr, size, char);
 
     /* The first SV in an arena isn't an SV. */
     SvANY(sva) = (void *) PL_sv_arenaroot;		/* ptr to next arena */
@@ -2327,7 +2327,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
         while (c < SvEND(sv)) {
             if (*c & 0x80) {
                 I32 len;
-                UV uv = utf8_to_uv(c, &len);
+                UV uv = utf8_to_uv((U8*)c, &len);
                 if (uv >= 256) {
 		    if (fail_ok)
 			return FALSE;
@@ -2351,7 +2351,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
             while (src < SvEND(sv)) {
                 if (*src & 0x80) {
                     I32 len;
-                    U8 u = (U8)utf8_to_uv(src, &len);
+                    U8 u = (U8)utf8_to_uv((U8*)src, &len);
                     *dst++ = u;
                     src += len;
                 }
@@ -2662,16 +2662,11 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 				    Perl_croak(aTHX_ 
 				    "Can't redefine active sort subroutine %s",
 					  GvENAME((GV*)dstr));
-				if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
-				    if (!(CvGV(cv) && GvSTASH(CvGV(cv))
-					  && HvNAME(GvSTASH(CvGV(cv)))
-					  && strEQ(HvNAME(GvSTASH(CvGV(cv))),
-						   "autouse")))
-					Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? 
+				if ((const_changed || const_sv) && ckWARN(WARN_REDEFINE))
+				    Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? 
 					     "Constant subroutine %s redefined"
 					     : "Subroutine %s redefined", 
 					     GvENAME((GV*)dstr));
-				}
 			    }
 			    cv_ckproto(cv, (GV*)dstr,
 				       SvPOK(sref) ? SvPVX(sref) : Nullch);
@@ -2812,8 +2807,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
     }
     else {
 	if (dtype == SVt_PVGV) {
-	    if (ckWARN(WARN_UNSAFE))
-		Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
+	    if (ckWARN(WARN_MISC))
+		Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
 	}
 	else
 	    (void)SvOK_off(dstr);
@@ -5734,6 +5729,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
     for (p = (char*)pat; p < patend; p = q) {
 	bool alt = FALSE;
 	bool left = FALSE;
+	bool vectorize = FALSE;
+	bool utf = FALSE;
 	char fill = ' ';
 	char plus = 0;
 	char intsize = 0;
@@ -5744,7 +5741,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	bool is_utf = FALSE;
 
 	char esignbuf[4];
-	U8 utf8buf[10];
+	U8 utf8buf[UTF8_MAXLEN];
 	STRLEN esignlen = 0;
 
 	char *eptr = Nullch;
@@ -5755,6 +5752,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	char ebuf[IV_DIG * 4 + NV_DIG + 32];
         /* large enough for "%#.#f" --chip */
 	/* what about long double NVs? --jhi */
+
+	SV *vecsv;
+	U8 *vecstr = Null(U8*);
+	STRLEN veclen = 0;
 	char c;
 	int i;
 	unsigned base;
@@ -5764,6 +5765,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	STRLEN have;
 	STRLEN need;
 	STRLEN gap;
+	char *dotstr = ".";
+	STRLEN dotstrlen = 1;
 
 	for (q = p; q < patend && *q != '%'; ++q) ;
 	if (q > p) {
@@ -5796,6 +5799,30 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		q++;
 		continue;
 
+	    case '*':			/* printf("%*vX",":",$ipv6addr) */
+		if (q[1] != 'v')
+		    break;
+		q++;
+		if (args)
+		    vecsv = va_arg(*args, SV*);
+		else if (svix < svmax)
+		    vecsv = svargs[svix++];
+		dotstr = SvPVx(vecsv,dotstrlen);
+		if (DO_UTF8(vecsv))
+		    is_utf = TRUE;
+		/* FALL THROUGH */
+
+	    case 'v':
+		vectorize = TRUE;
+		q++;
+		if (args)
+		    vecsv = va_arg(*args, SV*);
+		else if (svix < svmax)
+		    vecsv = svargs[svix++];
+		vecstr = (U8*)SvPVx(vecsv,veclen);
+		utf = DO_UTF8(vecsv);
+		continue;
+
 	    default:
 		break;
 	    }
@@ -5931,63 +5958,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    }
 	    goto string;
 
-	case 'v':
-	    if (args)
-		argsv = va_arg(*args, SV*);
-	    else if (svix < svmax)
-		argsv = svargs[svix++];
-	    {
-		STRLEN len;
-		U8 *str = (U8*)SvPVx(argsv,len);
-		I32 vlen = len*3+1;
-		SV *vsv = NEWSV(73,vlen);
-		I32 ulen;
-		I32 vfree = vlen;
-		U8 *vptr = (U8*)SvPVX(vsv);
-		STRLEN vcur = 0;
-		bool utf = DO_UTF8(argsv);
-
-		if (utf)
-		    is_utf = TRUE;
-		while (len) {
-		    UV uv;
-
-		    if (utf)
-			uv = utf8_to_uv(str, &ulen);
-		    else {
-			uv = *str;
-			ulen = 1;
-		    }
-		    str += ulen;
-		    len -= ulen;
-		    eptr = ebuf + sizeof ebuf;
-		    do {
-			*--eptr = '0' + uv % 10;
-		    } while (uv /= 10);
-		    elen = (ebuf + sizeof ebuf) - eptr;
-		    while (elen >= vfree-1) {
-			STRLEN off = vptr - (U8*)SvPVX(vsv);
-			vfree += vlen;
-			vlen *= 2;
-			SvGROW(vsv, vlen);
-			vptr = (U8*)SvPVX(vsv) + off;
-		    }
-		    memcpy(vptr, eptr, elen);
-		    vptr += elen;
-		    *vptr++ = '.';
-		    vfree -= elen + 1;
-		    vcur += elen + 1;
-		}
-		if (vcur) {
-		    vcur--;
-		    vptr[-1] = '\0';
-		}
-		SvCUR_set(vsv,vcur);
-		eptr = SvPVX(vsv);
-		elen = vcur;
-	    }
-	    goto string;
-
 	case '_':
 	    /*
 	     * The "%_" hack might have to be changed someday,
@@ -6002,6 +5972,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		is_utf = TRUE;
 
 	string:
+	    vectorize = FALSE;
 	    if (has_precis && elen > precis)
 		elen = precis;
 	    break;
@@ -6025,7 +5996,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    /* FALL THROUGH */
 	case 'd':
 	case 'i':
-	    if (args) {
+	    if (vectorize) {
+		I32 ulen;
+		if (!veclen) {
+		    vectorize = FALSE;
+		    break;
+		}
+		if (utf)
+		    iv = (IV)utf8_to_uv(vecstr, &ulen);
+		else {
+		    iv = *vecstr;
+		    ulen = 1;
+		}
+		vecstr += ulen;
+		veclen -= ulen;
+	    }
+	    else if (args) {
 		switch (intsize) {
 		case 'h':	iv = (short)va_arg(*args, int); break;
 		default:	iv = va_arg(*args, int); break;
@@ -6091,7 +6077,23 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    base = 16;
 
 	uns_integer:
-	    if (args) {
+	    if (vectorize) {
+		I32 ulen;
+	vector:
+		if (!veclen) {
+		    vectorize = FALSE;
+		    break;
+		}
+		if (utf)
+		    uv = utf8_to_uv(vecstr, &ulen);
+		else {
+		    uv = *vecstr;
+		    ulen = 1;
+		}
+		vecstr += ulen;
+		veclen -= ulen;
+	    }
+	    else if (args) {
 		switch (intsize) {
 		case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
 		default:   uv = va_arg(*args, unsigned); break;
@@ -6153,13 +6155,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		break;
 	    default:		/* it had better be ten or less */
 #if defined(PERL_Y2KWARN)
-		if (ckWARN(WARN_MISC)) {
+		if (ckWARN(WARN_Y2K)) {
 		    STRLEN n;
 		    char *s = SvPV(sv,n);
 		    if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
 			&& (n == 2 || !isDIGIT(s[n-3])))
 		    {
-			Perl_warner(aTHX_ WARN_MISC,
+			Perl_warner(aTHX_ WARN_Y2K,
 				    "Possible Y2K bug: %%%c %s",
 				    c, "format string following '19'");
 		    }
@@ -6191,6 +6193,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
 	    /* This is evil, but floating point is even more evil */
 
+	    vectorize = FALSE;
 	    if (args)
 		nv = va_arg(*args, NV);
 	    else
@@ -6258,6 +6261,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    /* SPECIAL */
 
 	case 'n':
+	    vectorize = FALSE;
 	    i = SvCUR(sv) - origlen;
 	    if (args) {
 		switch (intsize) {
@@ -6278,6 +6282,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
 	default:
       unknown:
+	    vectorize = FALSE;
 	    if (!args && ckWARN(WARN_PRINTF) &&
 		  (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
 		SV *msg = sv_newmortal();
@@ -6316,7 +6321,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	need = (have > width ? have : width);
 	gap = need - have;
 
-	SvGROW(sv, SvCUR(sv) + need + 1);
+	SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
 	p = SvEND(sv);
 	if (esignlen && fill == '0') {
 	    for (i = 0; i < esignlen; i++)
@@ -6342,10 +6347,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    memset(p, ' ', gap);
 	    p += gap;
 	}
+	if (vectorize) {
+	    if (veclen) {
+		memcpy(p, dotstr, dotstrlen);
+		p += dotstrlen;
+	    }
+	    else
+		vectorize = FALSE;		/* done iterating over vecstr */
+	}
 	if (is_utf)
 	    SvUTF8_on(sv);
 	*p = '\0';
 	SvCUR(sv) = p - SvPVX(sv);
+	if (vectorize) {
+	    esignlen = 0;
+	    goto vector;
+	}
     }
 }
 
@@ -7853,7 +7870,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_dirty		= proto_perl->Tdirty;
     PL_localizing	= proto_perl->Tlocalizing;
 
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
     PL_protect		= proto_perl->Tprotect;
+#endif
     PL_errors		= sv_dup_inc(proto_perl->Terrors);
     PL_av_fetch_sv	= Nullsv;
     PL_hv_fetch_sv	= Nullsv;