X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=5fd6533e4309da833e8319876fc9190aff25f984;hb=c5b802edbc2f0c65267eeef77229d452ab090751;hp=e068d0a83ff7e1663c7742d1c3334c4797a748e0;hpb=1554e226caad86d8d9b68656b257a3e2cc55803c;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/sv.c b/sv.c
index e068d0a..5fd6533 100644
--- a/sv.c
+++ b/sv.c
@@ -913,6 +913,10 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
     MAGIC*	magic;
     HV*		stash;
 
+    if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
+	sv_force_normal(sv);
+    }
+
     if (SvTYPE(sv) == mt)
 	return TRUE;
 
@@ -1493,6 +1497,9 @@ Perl_sv_2iv(pTHX_ register SV *sv)
 	      return SvIV(tmpstr);
 	  return PTR2IV(SvRV(sv));
 	}
+	if (SvREADONLY(sv) && SvFAKE(sv)) {
+	    sv_force_normal(sv);
+	}
 	if (SvREADONLY(sv) && !SvOK(sv)) {
 	    dTHR;
 	    if (ckWARN(WARN_UNINITIALIZED))
@@ -2444,8 +2451,13 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
         if (!utf8_to_bytes((U8*)c, &len)) {
 	    if (fail_ok)
 		return FALSE;
-	    else
-		Perl_croak(aTHX_ "big byte");
+	    else {
+		if (PL_op)
+		    Perl_croak(aTHX_ "Wide character in %s",
+			       PL_op_desc[PL_op->op_type]);
+		else
+		    Perl_croak(aTHX_ "Wide character");
+	    }
 	}
 	SvCUR(sv) = len - 1;
 	SvUTF8_off(sv);
@@ -2736,12 +2748,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 			    if (!GvCVGEN((GV*)dstr) &&
 				(CvROOT(cv) || CvXSUB(cv)))
 			    {
-				SV *const_sv = cv_const_sv(cv);
-				bool const_changed = TRUE;
-				if(const_sv)
-				    const_changed = sv_cmp(const_sv,
-					   op_const_sv(CvSTART((CV*)sref),
-						       (CV*)sref));
+ 				SV *const_sv;
 				/* ahem, death to those who redefine
 				 * active sort subs */
 				if (PL_curstackinfo->si_type == PERLSI_SORT &&
@@ -2749,11 +2756,20 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 				    Perl_croak(aTHX_
 				    "Can't redefine active sort subroutine %s",
 					  GvENAME((GV*)dstr));
-				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));
+ 				/* Redefining a sub - warning is mandatory if
+ 				   it was a const and its value changed. */
+ 				if (ckWARN(WARN_REDEFINE)
+ 				    || (CvCONST(cv)
+ 					&& (!CvCONST((CV*)sref)
+ 					    || sv_cmp(cv_const_sv(cv),
+ 						      cv_const_sv((CV*)sref)))))
+ 				{
+ 				    Perl_warner(aTHX_ WARN_REDEFINE,
+ 					CvCONST(cv)
+ 					? "Constant subroutine %s redefined"
+ 					: "Subroutine %s redefined",
+ 					GvENAME((GV*)dstr));
+ 				}
 			    }
 			    cv_ckproto(cv, (GV*)dstr,
 				       SvPOK(sref) ? SvPVX(sref) : Nullch);
@@ -4090,7 +4106,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
 	pv2 = SvPV(sv2, cur2);
 
     /* do not utf8ize the comparands as a side-effect */
-    if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE && 0) {
+    if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
 	if (SvUTF8(sv1)) {
 	    pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
 	    pv2tmp = TRUE;
@@ -5119,7 +5135,7 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash)
 		}
 		if (GvHV(gv) && !HvNAME(GvHV(gv))) {
 		    hv_clear(GvHV(gv));
-#ifndef VMS  /* VMS has no environ array */
+#if !defined( VMS) && !defined(EPOC)  /* VMS has no environ array */
 		    if (gv == PL_envgv)
 			environ[0] = Nullch;
 #endif
@@ -6041,7 +6057,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	bool has_precis = FALSE;
 	STRLEN precis = 0;
 	bool is_utf = FALSE;
-
+	
 	char esignbuf[4];
 	U8 utf8buf[UTF8_MAXLEN];
 	STRLEN esignlen = 0;
@@ -6069,6 +6085,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	STRLEN gap;
 	char *dotstr = ".";
 	STRLEN dotstrlen = 1;
+	I32 epix = 0; /* explicit parameter index */
+	I32 ewix = 0; /* explicit width index */
+	bool asterisk = FALSE;
 
 	for (q = p; q < patend && *q != '%'; ++q) ;
 	if (q > p) {
@@ -6129,6 +6148,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
 	/* WIDTH */
 
+    scanwidth:
+
+	if (*q == '*') {
+	    if (asterisk)
+		goto unknown;
+	    asterisk = TRUE;
+	    q++;
+	}
+
 	switch (*q) {
 	case '1': case '2': case '3':
 	case '4': case '5': case '6':
@@ -6136,17 +6164,30 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    width = 0;
 	    while (isDIGIT(*q))
 		width = width * 10 + (*q++ - '0');
-	    break;
+	    if (*q == '$') {
+		if (asterisk && ewix == 0) {
+		    ewix  = width;
+		    width = 0;
+		    q++;
+		    goto scanwidth;
+		} else if (epix == 0) {
+		    epix  = width;
+		    width = 0;
+		    q++;
+		    goto scanwidth;
+		} else
+		    goto unknown;
+	    }
+	}
 
-	case '*':
+	if (asterisk) {
 	    if (args)
 		i = va_arg(*args, int);
 	    else
-		i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+		i = (ewix ? ewix <= svmax : svix < svmax) ?
+		    SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
 	    left |= (i < 0);
 	    width = (i < 0) ? -i : i;
-	    q++;
-	    break;
 	}
 
 	/* PRECISION */
@@ -6157,7 +6198,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		if (args)
 		    i = va_arg(*args, int);
 		else
-		    i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+		    i = (ewix ? ewix <= svmax : svix < svmax)
+			? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
 		precis = (i < 0) ? 0 : i;
 		q++;
 	    }
@@ -6175,8 +6217,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		vecstr = (U8*)SvPVx(vecsv,veclen);
 		utf = DO_UTF8(vecsv);
 	    }
-	    else if (svix < svmax) {
-		vecsv = svargs[svix++];
+	    else if (epix ? epix <= svmax : svix < svmax) {
+		vecsv = svargs[epix ? epix-1 : svix++];
 		vecstr = (U8*)SvPVx(vecsv,veclen);
 		utf = DO_UTF8(vecsv);
 	    }
@@ -6230,7 +6272,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    if (args)
 		uv = va_arg(*args, int);
 	    else
-		uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+		uv = (epix ? epix <= svmax : svix < svmax) ?
+		    SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
 	    if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
 		eptr = (char*)utf8buf;
 		elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
@@ -6259,8 +6302,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		    elen = sizeof nullstr - 1;
 		}
 	    }
-	    else if (svix < svmax) {
-		argsv = svargs[svix++];
+	    else if (epix ? epix <= svmax : svix < svmax) {
+		argsv = svargs[epix ? epix-1 : svix++];
 		eptr = SvPVx(argsv, elen);
 		if (DO_UTF8(argsv)) {
 		    if (has_precis && precis < elen) {
@@ -6303,7 +6346,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    if (args)
 		uv = PTR2UV(va_arg(*args, void*));
 	    else
-		uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
+		uv = (epix ? epix <= svmax : svix < svmax) ?
+		    PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
 	    base = 16;
 	    goto integer;
 
@@ -6317,13 +6361,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	case 'd':
 	case 'i':
 	    if (vectorize) {
-		I32 ulen;
+		STRLEN ulen;
 		if (!veclen) {
 		    vectorize = FALSE;
 		    break;
 		}
 		if (utf)
-		    iv = (IV)utf8_to_uv_chk(vecstr, &ulen, 0);
+		    iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
 		else {
 		    iv = *vecstr;
 		    ulen = 1;
@@ -6343,7 +6387,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		}
 	    }
 	    else {
-		iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+		iv = (epix ? epix <= svmax : svix < svmax) ?
+		    SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
 		switch (intsize) {
 		case 'h':	iv = (short)iv; break;
 		default:	break;
@@ -6398,14 +6443,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
 	uns_integer:
 	    if (vectorize) {
-		I32 ulen;
+		STRLEN ulen;
 	vector:
 		if (!veclen) {
 		    vectorize = FALSE;
 		    break;
 		}
 		if (utf)
-		    uv = utf8_to_uv_chk(vecstr, &ulen, 0);
+		    uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
 		else {
 		    uv = *vecstr;
 		    ulen = 1;
@@ -6425,7 +6470,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		}
 	    }
 	    else {
-		uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
+		uv = (epix ? epix <= svmax : svix < svmax) ?
+		    SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
 		switch (intsize) {
 		case 'h':	uv = (unsigned short)uv; break;
 		default:	break;
@@ -6517,7 +6563,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    if (args)
 		nv = va_arg(*args, NV);
 	    else
-		nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
+		nv = (epix ? epix <= svmax : svix < svmax) ?
+		    SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
 
 	    need = 0;
 	    if (c != 'e' && c != 'E') {
@@ -6602,8 +6649,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 #endif
 		}
 	    }
-	    else if (svix < svmax)
-		sv_setuv_mg(svargs[svix++], (UV)i);
+	    else if (epix ? epix <= svmax : svix < svmax)
+		sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
 	    continue;	/* not "break" */
 
 	    /* UNKNOWN */