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

diff --git a/sv.c b/sv.c
index 2c45cae..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;
 
@@ -1488,10 +1492,14 @@ Perl_sv_2iv(pTHX_ register SV *sv)
     if (SvTHINKFIRST(sv)) {
 	if (SvROK(sv)) {
 	  SV* tmpstr;
-	  if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
+          if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
+                  (SvRV(tmpstr) != SvRV(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))
@@ -1618,7 +1626,8 @@ Perl_sv_2uv(pTHX_ register SV *sv)
     if (SvTHINKFIRST(sv)) {
 	if (SvROK(sv)) {
 	  SV* tmpstr;
-	  if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
+          if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
+                  (SvRV(tmpstr) != SvRV(sv)))
 	      return SvUV(tmpstr);
 	  return PTR2UV(SvRV(sv));
 	}
@@ -1785,7 +1794,8 @@ Perl_sv_2nv(pTHX_ register SV *sv)
     if (SvTHINKFIRST(sv)) {
 	if (SvROK(sv)) {
 	  SV* tmpstr;
-	  if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
+          if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
+                  (SvRV(tmpstr) != SvRV(sv)))
 	      return SvNV(tmpstr);
 	  return PTR2NV(SvRV(sv));
 	}
@@ -2112,7 +2122,8 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
     if (SvTHINKFIRST(sv)) {
 	if (SvROK(sv)) {
 	    SV* tmpstr;
-	    if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
+            if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
+                    (SvRV(tmpstr) != SvRV(sv)))
 		return SvPV(tmpstr,*lp);
 	    sv = (SV*)SvRV(sv);
 	    if (!sv)
@@ -2359,7 +2370,8 @@ Perl_sv_2bool(pTHX_ register SV *sv)
     if (SvROK(sv)) {
 	dTHR;
 	SV* tmpsv;
-	if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
+        if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
+                (SvRV(tmpsv) != SvRV(sv)))
 	    return SvTRUE(tmpsv);
       return SvRV(sv) != 0;
     }
@@ -2396,28 +2408,26 @@ Convert the PV of an SV to its UTF8-encoded form.
 void
 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 {
-    int hicount;
-    char *c;
-    char *s;
+    char *s, *t;
+    bool hibit;
 
     if (!sv || !SvPOK(sv) || SvUTF8(sv))
 	return;
 
-    /* This function could be much more efficient if we had a FLAG
-     * to signal if there are any hibit chars in the string
+    /* This function could be much more efficient if we had a FLAG in SVs
+     * to signal if there are any hibit chars in the PV.
      */
-    hicount = 0;
-    for (c = s = SvPVX(sv); c < SvEND(sv); c++) {
-	if (*c & 0x80)
-	    hicount++;
-    }
+    for (s = t = SvPVX(sv), hibit = FALSE; t < SvEND(sv) && !hibit; t++)
+	if (*t & 0x80)
+	    hibit = TRUE;
 
-    if (hicount) {
+    if (hibit) {
 	STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
-	SvPVX(sv) = bytes_to_utf8(s, &len);
+	SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
 	SvCUR(sv) = len - 1;
-	Safefree(s); /* No longer using what was there before */
+	SvLEN(sv) = len; /* No longer know the real size. */
 	SvUTF8_on(sv);
+	Safefree(s); /* No longer using what was there before. */
     }
 }
 
@@ -2437,14 +2447,20 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
 {
     if (SvPOK(sv) && SvUTF8(sv)) {
         char *c = SvPVX(sv);
-	STRLEN len = SvCUR(sv);
-        if (!utf8_to_bytes(c, &len)) {
+	STRLEN len = SvCUR(sv) + 1;	/* include trailing NUL */
+        if (!utf8_to_bytes((U8*)c, &len)) {
 	    if (fail_ok)
 		return FALSE;
-	    else
-		Perl_croak("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);
     }
     return TRUE;
 }
@@ -2478,7 +2494,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv)
          * we want to make sure everything inside is valid utf8 first.
          */
         c = SvPVX(sv);
-	if (!is_utf8_string(c,SvCUR(c)+1))
+	if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
 	    return FALSE;
 
         while (c < SvEND(sv)) {
@@ -2732,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 &&
@@ -2745,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);
@@ -4086,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;
@@ -5115,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
@@ -6037,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;
@@ -6065,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) {
@@ -6125,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':
@@ -6132,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 */
@@ -6153,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++;
 	    }
@@ -6171,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);
 	    }
@@ -6226,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;
@@ -6255,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) {
@@ -6299,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;
 
@@ -6313,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(vecstr, &ulen, 0);
+		    iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
 		else {
 		    iv = *vecstr;
 		    ulen = 1;
@@ -6339,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;
@@ -6394,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(vecstr, &ulen, 0);
+		    uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
 		else {
 		    uv = *vecstr;
 		    ulen = 1;
@@ -6421,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;
@@ -6513,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') {
@@ -6598,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 */