X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=581c788318551c43504957e97908a9c291ff12ce;hb=3f939f220e50adb6f28f2dd14f06461c7cebfe14;hp=a448938d46866e6165d3e84bd142cfdcc29a1284;hpb=14befaf4eaa6e79d87aacb106e0b701e925483ee;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/sv.c b/sv.c
index a448938..581c788 100644
--- a/sv.c
+++ b/sv.c
@@ -2306,7 +2306,10 @@ Perl_sv_2nv(pTHX_ register SV *sv)
     }
     else if (SvTYPE(sv) < SVt_PVNV)
 	sv_upgrade(sv, SVt_PVNV);
-    if (SvIOKp(sv) &&
+    if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
+	SvNOK_on(sv);
+    }
+    else if (SvIOKp(sv) &&
 	    (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
     {
 	SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
@@ -2526,11 +2529,11 @@ Perl_looks_like_number(pTHX_ SV *sv)
 			   UV_MAX= 18446744073709551615) so be cautious  */
 	    numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
 
-        if (*s == '.'
+        if (
 #ifdef USE_LOCALE_NUMERIC
-	    || (specialradix = IS_NUMERIC_RADIX(s))
+	    (specialradix = IS_NUMERIC_RADIX(s, send)) ||
 #endif
-	    ) {
+	    *s == '.') {
 #ifdef USE_LOCALE_NUMERIC
 	    if (specialradix)
 		s += SvCUR(PL_numeric_radix_sv);
@@ -2542,10 +2545,11 @@ Perl_looks_like_number(pTHX_ SV *sv)
                 s++;
         }
     }
-    else if (*s == '.'
+    else if (
 #ifdef USE_LOCALE_NUMERIC
-	    || (specialradix = IS_NUMERIC_RADIX(s))
+	     (specialradix = IS_NUMERIC_RADIX(s, send)) ||
 #endif
+	    *s == '.'
 	    ) {
 #ifdef USE_LOCALE_NUMERIC
 	if (specialradix)
@@ -2643,6 +2647,12 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
 char *
 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
 {
+    return sv_2pv_flags(sv, lp, SV_GMAGIC);
+}
+
+char *
+Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
+{
     register char *s;
     int olderrno;
     SV *tsv;
@@ -2654,7 +2664,8 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
 	return "";
     }
     if (SvGMAGICAL(sv)) {
-	mg_get(sv);
+	if (flags & SV_GMAGIC)
+	    mg_get(sv);
 	if (SvPOKp(sv)) {
 	    *lp = SvCUR(sv);
 	    return SvPVX(sv);
@@ -2965,6 +2976,25 @@ if all the bytes have hibit clear.
 STRLEN
 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 {
+    return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
+}
+
+/*
+=for apidoc sv_utf8_upgrade_flags
+
+Convert the PV of an SV to its UTF8-encoded form.
+Forces the SV to string form it it is not already.
+Always sets the SvUTF8 flag to avoid future validity checks even
+if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
+will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
+C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
+
+=cut
+*/
+
+STRLEN
+Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
+{
     U8 *s, *t, *e;
     int  hibit = 0;
 
@@ -2973,7 +3003,7 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 
     if (!SvPOK(sv)) {
 	STRLEN len = 0;
-	(void) sv_2pv(sv,&len);
+	(void) sv_2pv_flags(sv,&len, flags);
 	if (!SvPOK(sv))
 	     return len;
     }
@@ -3038,7 +3068,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
 	        if (fail_ok)
 		    return FALSE;
 #ifdef USE_BYTES_DOWNGRADES
-		else if (IN_BYTE) {
+		else if (IN_BYTES) {
 		    U8 *d = s;
 		    U8 *e = (U8 *) SvEND(sv);
 		    int first = 1;
@@ -3149,9 +3179,30 @@ C<sv_setsv_mg>.
 =cut
 */
 
+/* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
+   for binary compatibility only
+*/
 void
 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 {
+    sv_setsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
+/*
+=for apidoc sv_setsv_flags
+
+Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
+The source SV may be destroyed if it is mortal.  Does not handle 'set'
+magic.  If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
+appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented
+in terms of this function.
+
+=cut
+*/
+
+void
+Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
+{
     register U32 sflags;
     register int dtype;
     register int stype;
@@ -3305,7 +3356,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 	/* FALL THROUGH */
 
     default:
-	if (SvGMAGICAL(sstr)) {
+	if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
 	    mg_get(sstr);
 	    if (SvTYPE(sstr) != stype) {
 		stype = SvTYPE(sstr);
@@ -3627,7 +3678,8 @@ Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN
     else {
         /* len is STRLEN which is unsigned, need to copy to signed */
 	IV iv = len;
-	assert(iv >= 0);
+	if (iv < 0)
+	    Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
     }
     (void)SvUPGRADE(sv, SVt_PV);
 
@@ -3833,21 +3885,43 @@ Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
 =cut
 */
 
+/* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
+   for binary compatibility only
+*/
 void
-Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
+Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
 {
-    STRLEN tlen;
-    char *junk;
+    sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
+}
 
-    junk = SvPV_force(sv, tlen);
-    SvGROW(sv, tlen + len + 1);
-    if (ptr == junk)
-	ptr = SvPVX(sv);
-    Move(ptr,SvPVX(sv)+tlen,len,char);
-    SvCUR(sv) += len;
-    *SvEND(sv) = '\0';
-    (void)SvPOK_only_UTF8(sv);		/* validate pointer */
-    SvTAINT(sv);
+/*
+=for apidoc sv_catpvn_flags
+
+Concatenates the string onto the end of the string which is in the SV.  The
+C<len> indicates number of bytes to copy.  If the SV has the UTF8
+status set, then the bytes appended should be valid UTF8.
+If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
+appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
+in terms of this function.
+
+=cut
+*/
+
+void
+Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
+{
+    STRLEN dlen;
+    char *dstr;
+
+    dstr = SvPV_force_flags(dsv, dlen, flags);
+    SvGROW(dsv, dlen + slen + 1);
+    if (sstr == dstr)
+	sstr = SvPVX(dsv);
+    Move(sstr, SvPVX(dsv) + dlen, slen, char);
+    SvCUR(dsv) += slen;
+    *SvEND(dsv) = '\0';
+    (void)SvPOK_only_UTF8(dsv);		/* validate pointer */
+    SvTAINT(dsv);
 }
 
 /*
@@ -3874,36 +3948,52 @@ not 'set' magic.  See C<sv_catsv_mg>.
 
 =cut */
 
+/* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
+   for binary compatibility only
+*/
+void
+Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
+{
+    sv_catsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
+/*
+=for apidoc sv_catsv_flags
+
+Concatenates the string from SV C<ssv> onto the end of the string in
+SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
+bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
+and C<sv_catsv_nomg> are implemented in terms of this function.
+
+=cut */
+
 void
-Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
+Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
 {
     char *spv;
     STRLEN slen;
     if (!ssv)
 	return;
     if ((spv = SvPV(ssv, slen))) {
-	bool dutf8 = DO_UTF8(dsv);
 	bool sutf8 = DO_UTF8(ssv);
+	bool dutf8;
 
-	if (dutf8 == sutf8)
-	    sv_catpvn(dsv,spv,slen);
-	else {
+	if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
+	    mg_get(dsv);
+	dutf8 = DO_UTF8(dsv);
+
+	if (dutf8 != sutf8) {
 	    if (dutf8) {
 		/* Not modifying source SV, so taking a temporary copy. */
-		SV* csv = sv_2mortal(newSVsv(ssv));
-		char *cpv;
-		STRLEN clen;
+		SV* csv = sv_2mortal(newSVpvn(spv, slen));
 
 		sv_utf8_upgrade(csv);
-		cpv = SvPV(csv,clen);
-		sv_catpvn(dsv,cpv,clen);
-	    }
-	    else {
-		sv_utf8_upgrade(dsv);
-		sv_catpvn(dsv,spv,slen);
-		SvUTF8_on(dsv); /* If dsv has no wide characters. */
+		spv = SvPV(csv, slen);
 	    }
+	    else
+		sv_utf8_upgrade_nomg(dsv);
 	}
+	sv_catpvn_nomg(dsv, spv, slen);
     }
 }
 
@@ -4206,7 +4296,7 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type)
     }
     if (!SvMAGIC(sv)) {
 	SvMAGICAL_off(sv);
-	SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+       SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
     }
 
     return 0;
@@ -4804,7 +4894,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) {
+    if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
 	bool is_utf8 = TRUE;
         /* UTF-8ness differs */
 	if (PL_hints & HINT_UTF8_DISTINCT)
@@ -4871,7 +4961,7 @@ Perl_sv_cmp(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) {
+    if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
 	if (PL_hints & HINT_UTF8_DISTINCT)
 	    return SvUTF8(sv1) ? 1 : -1;
 
@@ -5036,7 +5126,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
     register STDCHAR rslast;
     register STDCHAR *bp;
     register I32 cnt;
-    I32 i;
+    I32 i = 0;
 
     SV_CHECK_THINKFIRST(sv);
     (void)SvUPGRADE(sv, SVt_PV);
@@ -6168,6 +6258,23 @@ Get a sensible string out of the SV somehow.
 char *
 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
 {
+    return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
+}
+
+/*
+=for apidoc sv_pvn_force_flags
+
+Get a sensible string out of the SV somehow.
+If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
+appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
+implemented in terms of this function.
+
+=cut
+*/
+
+char *
+Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
+{
     char *s;
 
     if (SvTHINKFIRST(sv) && !SvROK(sv))
@@ -6182,7 +6289,7 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
 		PL_op_name[PL_op->op_type]);
 	}
 	else
-	    s = sv_2pv(sv, lp);
+	    s = sv_2pv_flags(sv, lp, flags);
 	if (s != SvPVX(sv)) {	/* Almost, but not quite, sv_setpvn() */
 	    STRLEN len = *lp;
 	
@@ -6885,7 +6992,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
     STRLEN origlen;
     I32 svix = 0;
     static char nullstr[] = "(null)";
-    SV *argsv;
+    SV *argsv = Nullsv;
 
     /* no matter what, this is a string now */
     (void)SvPV_force(sv, origlen);
@@ -6953,7 +7060,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	STRLEN veclen = 0;
 	char c;
 	int i;
-	unsigned base;
+	unsigned base = 0;
 	IV iv;
 	UV uv;
 	NV nv;
@@ -7159,7 +7266,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    uv = args ? va_arg(*args, int) : SvIVx(argsv);
 	    if ((uv > 255 ||
 		 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
-		&& !IN_BYTE) {
+		&& !IN_BYTES) {
 		eptr = (char*)utf8buf;
 		elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
 		is_utf = TRUE;
@@ -7980,14 +8087,18 @@ Perl_sv_dup(pTHX_ SV *sstr)
 	break;
     case SVt_RV:
 	SvANY(dstr)	= new_XRV();
-	SvRV(dstr)	= sv_dup_inc(SvRV(sstr));
+	SvRV(dstr)	= SvRV(sstr) && SvWEAKREF(SvRV(sstr))
+			? sv_dup(SvRV(sstr))
+			: sv_dup_inc(SvRV(sstr));
 	break;
     case SVt_PV:
 	SvANY(dstr)	= new_XPV();
 	SvCUR(dstr)	= SvCUR(sstr);
 	SvLEN(dstr)	= SvLEN(sstr);
 	if (SvROK(sstr))
-	    SvRV(dstr)	= sv_dup_inc(SvRV(sstr));
+	    SvRV(dstr)	= SvWEAKREF(SvRV(sstr))
+			? sv_dup(SvRV(sstr))
+			: sv_dup_inc(SvRV(sstr));
 	else if (SvPVX(sstr) && SvLEN(sstr))
 	    SvPVX(dstr)	= SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
 	else
@@ -7999,7 +8110,9 @@ Perl_sv_dup(pTHX_ SV *sstr)
 	SvLEN(dstr)	= SvLEN(sstr);
 	SvIVX(dstr)	= SvIVX(sstr);
 	if (SvROK(sstr))
-	    SvRV(dstr)	= sv_dup_inc(SvRV(sstr));
+	    SvRV(dstr)	= SvWEAKREF(SvRV(sstr))
+			? sv_dup(SvRV(sstr))
+			: sv_dup_inc(SvRV(sstr));
 	else if (SvPVX(sstr) && SvLEN(sstr))
 	    SvPVX(dstr)	= SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
 	else
@@ -8012,7 +8125,9 @@ Perl_sv_dup(pTHX_ SV *sstr)
 	SvIVX(dstr)	= SvIVX(sstr);
 	SvNVX(dstr)	= SvNVX(sstr);
 	if (SvROK(sstr))
-	    SvRV(dstr)	= sv_dup_inc(SvRV(sstr));
+	    SvRV(dstr)	= SvWEAKREF(SvRV(sstr))
+			? sv_dup(SvRV(sstr))
+			: sv_dup_inc(SvRV(sstr));
 	else if (SvPVX(sstr) && SvLEN(sstr))
 	    SvPVX(dstr)	= SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
 	else
@@ -8027,7 +8142,9 @@ Perl_sv_dup(pTHX_ SV *sstr)
 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr));
 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr));
 	if (SvROK(sstr))
-	    SvRV(dstr)	= sv_dup_inc(SvRV(sstr));
+	    SvRV(dstr)	= SvWEAKREF(SvRV(sstr))
+			? sv_dup(SvRV(sstr))
+			: sv_dup_inc(SvRV(sstr));
 	else if (SvPVX(sstr) && SvLEN(sstr))
 	    SvPVX(dstr)	= SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
 	else
@@ -8042,7 +8159,9 @@ Perl_sv_dup(pTHX_ SV *sstr)
 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr));
 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr));
 	if (SvROK(sstr))
-	    SvRV(dstr)	= sv_dup_inc(SvRV(sstr));
+	    SvRV(dstr)	= SvWEAKREF(SvRV(sstr))
+			? sv_dup(SvRV(sstr))
+			: sv_dup_inc(SvRV(sstr));
 	else if (SvPVX(sstr) && SvLEN(sstr))
 	    SvPVX(dstr)	= SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
 	else
@@ -8060,7 +8179,9 @@ Perl_sv_dup(pTHX_ SV *sstr)
 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr));
 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr));
 	if (SvROK(sstr))
-	    SvRV(dstr)	= sv_dup_inc(SvRV(sstr));
+	    SvRV(dstr)	= SvWEAKREF(SvRV(sstr))
+			? sv_dup(SvRV(sstr))
+			: sv_dup_inc(SvRV(sstr));
 	else if (SvPVX(sstr) && SvLEN(sstr))
 	    SvPVX(dstr)	= SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
 	else
@@ -8091,7 +8212,9 @@ Perl_sv_dup(pTHX_ SV *sstr)
 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr));
 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr));
 	if (SvROK(sstr))
-	    SvRV(dstr)	= sv_dup_inc(SvRV(sstr));
+	    SvRV(dstr)	= SvWEAKREF(SvRV(sstr))
+			? sv_dup(SvRV(sstr))
+			: sv_dup_inc(SvRV(sstr));
 	else if (SvPVX(sstr) && SvLEN(sstr))
 	    SvPVX(dstr)	= SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
 	else
@@ -8112,7 +8235,9 @@ Perl_sv_dup(pTHX_ SV *sstr)
 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr));
 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr));
 	if (SvROK(sstr))
-	    SvRV(dstr)	= sv_dup_inc(SvRV(sstr));
+	    SvRV(dstr)	= SvWEAKREF(SvRV(sstr))
+			? sv_dup(SvRV(sstr))
+			: sv_dup_inc(SvRV(sstr));
 	else if (SvPVX(sstr) && SvLEN(sstr))
 	    SvPVX(dstr)	= SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
 	else
@@ -9381,7 +9506,7 @@ do_clean_objs(pTHXo_ SV *sv)
     SV* rv;
 
     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
-	DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
+	DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
 	if (SvWEAKREF(sv)) {
 	    sv_del_backref(sv);
 	    SvWEAKREF_off(sv);
@@ -9407,7 +9532,7 @@ do_clean_named_objs(pTHXo_ SV *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));)
+	    DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
 	    SvREFCNT_dec(sv);
 	}
     }
@@ -9417,7 +9542,7 @@ do_clean_named_objs(pTHXo_ SV *sv)
 static void
 do_clean_all(pTHXo_ SV *sv)
 {
-    DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
+    DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
     SvFLAGS(sv) |= SVf_BREAK;
     SvREFCNT_dec(sv);
 }