X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=ab4d6d55e73b38318882b04d507e891dce1f0bcc;hb=7ed149c909e2812f62b12bd7d09f4ccfb79e0041;hp=df2dce63ab5b5fd669309950f7358e969305ac00;hpb=612f20c37ac59506501c890e7f9285f551c793d2;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/sv.c b/sv.c
index df2dce6..ab4d6d5 100644
--- a/sv.c
+++ b/sv.c
@@ -1569,22 +1569,13 @@ Perl_sv_2iv(pTHX_ register SV *sv)
 		goto ret_iv_max;
 	    }
 	}
-	else if (numtype) {
-	    /* The NV may be reconstructed from IV - safe to cache IV,
-	       which may be calculated by atol(). */
-	    if (SvTYPE(sv) == SVt_PV)
-		sv_upgrade(sv, SVt_PVIV);
-	    (void)SvIOK_on(sv);
-	    SvIVX(sv) = Atol(SvPVX(sv));
-	}
-	else {				/* Not a number.  Cache 0. */
-	    dTHR;
-
+	else {	/* The NV may be reconstructed from IV - safe to cache IV,
+		   which may be calculated by atol(). */
 	    if (SvTYPE(sv) < SVt_PVIV)
 		sv_upgrade(sv, SVt_PVIV);
 	    (void)SvIOK_on(sv);
-	    SvIVX(sv) = 0;
-	    if (ckWARN(WARN_NUMERIC))
+	    SvIVX(sv) = Atol(SvPVX(sv));
+	    if (! numtype && ckWARN(WARN_NUMERIC))
 		not_a_number(sv);
 	}
     }
@@ -2182,7 +2173,10 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
 		case SVt_PV:
 		case SVt_PVIV:
 		case SVt_PVNV:
-		case SVt_PVBM:	s = "SCALAR";			break;
+		case SVt_PVBM:	if (SvROK(sv))
+				    s = "REF";
+				else
+				    s = "SCALAR";		break;
 		case SVt_PVLV:	s = "LVALUE";			break;
 		case SVt_PVAV:	s = "ARRAY";			break;
 		case SVt_PVHV:	s = "HASH";			break;
@@ -2390,6 +2384,14 @@ Perl_sv_2bool(pTHX_ register SV *sv)
     }
 }
 
+/*
+=for apidoc sv_utf8_upgrade
+
+Convert the PV of an SV to its UTF8-encoded form.
+
+=cut
+*/
+
 void
 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 {
@@ -2431,6 +2433,17 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
     }
 }
 
+/*
+=for apidoc sv_utf8_downgrade
+
+Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
+This may not be possible if the PV contains non-byte encoding characters;
+if this is the case, either returns false or, if C<fail_ok> is not
+true, croaks.
+
+=cut
+*/
+
 bool
 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
 {
@@ -2480,6 +2493,15 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
     return TRUE;
 }
 
+/*
+=for apidoc sv_utf8_encode
+
+Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
+flag so that it looks like bytes again. Nothing calls this. 
+
+=cut
+*/
+
 void
 Perl_sv_utf8_encode(pTHX_ register SV *sv)
 {
@@ -2659,7 +2681,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 		char *name = GvNAME(sstr);
 		STRLEN len = GvNAMELEN(sstr);
 		sv_upgrade(dstr, SVt_PVGV);
-		sv_magic(dstr, dstr, '*', name, len);
+		sv_magic(dstr, dstr, '*', Nullch, 0);
 		GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
 		GvNAME(dstr) = savepvn(name, len);
 		GvNAMELEN(dstr) = len;
@@ -2768,7 +2790,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 				if(const_sv)
 				    const_changed = sv_cmp(const_sv, 
 					   op_const_sv(CvSTART((CV*)sref), 
-						       Nullcv));
+						       (CV*)sref));
 				/* ahem, death to those who redefine
 				 * active sort subs */
 				if (PL_curstackinfo->si_type == PERLSI_SORT &&
@@ -2776,7 +2798,7 @@ 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))
+				if ((const_changed && const_sv) || ckWARN(WARN_REDEFINE))
 				    Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? 
 					     "Constant subroutine %s redefined"
 					     : "Subroutine %s redefined", 
@@ -2803,6 +2825,13 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 			dref = (SV*)GvIOp(dstr);
 		    GvIOp(dstr) = (IO*)sref;
 		    break;
+		case SVt_PVFM:
+		    if (intro)
+			SAVESPTR(GvFORM(dstr));
+		    else
+			dref = (SV*)GvFORM(dstr);
+		    GvFORM(dstr) = (CV*)sref;
+		    break;
 		default:
 		    if (intro)
 			SAVESPTR(GvSV(dstr));
@@ -3451,6 +3480,14 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
 	SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
 }
 
+/*
+=for apidoc sv_unmagic
+
+Removes magic from an SV.
+
+=cut
+*/
+
 int
 Perl_sv_unmagic(pTHX_ SV *sv, int type)
 {
@@ -3485,6 +3522,14 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type)
     return 0;
 }
 
+/*
+=for apidoc sv_rvweaken
+
+Weaken a reference.
+
+=cut
+*/
+
 SV *
 Perl_sv_rvweaken(pTHX_ SV *sv)
 {
@@ -3636,7 +3681,13 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN
     SvSETMAGIC(bigstr);
 }
 
-/* make sv point to what nstr did */
+/*
+=for apidoc sv_replace
+
+Make the first argument a copy of the second, then delete the original.
+
+=cut
+*/
 
 void
 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
@@ -3665,6 +3716,15 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
     del_SV(nsv);
 }
 
+/*
+=for apidoc sv_clear
+
+Clear an SV, making it empty. Does not free the memory used by the SV
+itself.
+
+=cut
+*/
+
 void
 Perl_sv_clear(pTHX_ register SV *sv)
 {
@@ -3858,6 +3918,14 @@ Perl_sv_newref(pTHX_ SV *sv)
     return sv;
 }
 
+/*
+=for apidoc sv_free
+
+Free the memory used by an SV.
+
+=cut
+*/
+
 void
 Perl_sv_free(pTHX_ SV *sv)
 {
@@ -3926,6 +3994,15 @@ Perl_sv_len(pTHX_ register SV *sv)
     return len;
 }
 
+/*
+=for apidoc sv_len_utf8
+
+Returns the number of characters in the string in an SV, counting wide
+UTF8 bytes as a single character.
+
+=cut
+*/
+
 STRLEN
 Perl_sv_len_utf8(pTHX_ register SV *sv)
 {
@@ -4021,38 +4098,51 @@ identical.
 */
 
 I32
-Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
+Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
 {
     char *pv1;
     STRLEN cur1;
     char *pv2;
     STRLEN cur2;
+    I32  eq     = 0;
+    bool pv1tmp = FALSE;
+    bool pv2tmp = FALSE;
 
-    if (!str1) {
+    if (!sv1) {
 	pv1 = "";
 	cur1 = 0;
     }
     else
-	pv1 = SvPV(str1, cur1);
+	pv1 = SvPV(sv1, cur1);
 
-    if (cur1) {
-	if (!str2)
-	    return 0;
-	if (SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
-	    if (SvUTF8(str1)) {
-		sv_utf8_upgrade(str2);
-	    }
-	    else {
-		sv_utf8_upgrade(str1);
-	    }
+    if (!sv2){
+	pv2 = "";
+	cur2 = 0;
+    }
+    else
+	pv2 = SvPV(sv2, cur2);
+
+    /* do not utf8ize the comparands as a side-effect */
+    if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE && 0) {
+	if (SvUTF8(sv1)) {
+	    pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
+	    pv2tmp = TRUE;
+	}
+	else {
+	    pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
+	    pv1tmp = TRUE;
 	}
     }
-    pv2 = SvPV(str2, cur2);
 
-    if (cur1 != cur2)
-	return 0;
+    if (cur1 == cur2)
+	eq = memEQ(pv1, pv2, cur1);
+	
+    if (pv1tmp)
+	Safefree(pv1);
+    if (pv2tmp)
+	Safefree(pv2);
 
-    return memEQ(pv1, pv2, cur1);
+    return eq;
 }
 
 /*
@@ -4066,60 +4156,72 @@ C<sv2>.
 */
 
 I32
-Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
+Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
 {
     STRLEN cur1, cur2;
     char *pv1, *pv2;
-    I32 retval;
+    I32  cmp; 
+    bool pv1tmp = FALSE;
+    bool pv2tmp = FALSE;
 
-    if (str1) {
-        pv1 = SvPV(str1, cur1);
-    }
-    else {
+    if (!sv1) {
+	pv1 = "";
 	cur1 = 0;
     }
+    else
+	pv1 = SvPV(sv1, cur1);
 
-    if (str2) {
-	if (SvPOK(str2)) {
-	    if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
-		/* must upgrade other to UTF8 first */
-		if (SvUTF8(str1)) {
-		    sv_utf8_upgrade(str2);
-		}
-		else {
-		    sv_utf8_upgrade(str1);
-		    /* refresh pointer and length */
-		    pv1  = SvPVX(str1);
-		    cur1 = SvCUR(str1);
-		}
-	    }
-	    pv2  = SvPVX(str2);
-	    cur2 = SvCUR(str2);
-    	}
+    if (!sv2){
+	pv2 = "";
+	cur2 = 0;
+    }
+    else
+	pv2 = SvPV(sv2, cur2);
+
+    /* do not utf8ize the comparands as a side-effect */
+    if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+	if (SvUTF8(sv1)) {
+	    pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
+	    pv2tmp = TRUE;
+	}
 	else {
-	    pv2 = sv_2pv(str2, &cur2);
+	    pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
+	    pv1tmp = TRUE;
 	}
     }
-    else {
-	cur2 = 0;
+
+    if (!cur1) {
+	cmp = cur2 ? -1 : 0;
+    } else if (!cur2) {
+	cmp = 1;
+    } else {
+	I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
+
+	if (retval) {
+	    cmp = retval < 0 ? -1 : 1;
+	} else if (cur1 == cur2) {
+	    cmp = 0;
+        } else {
+	    cmp = cur1 < cur2 ? -1 : 1;
+	}
     }
 
-    if (!cur1)
-	return cur2 ? -1 : 0;
+    if (pv1tmp)
+	Safefree(pv1);
+    if (pv2tmp)
+	Safefree(pv2);
 
-    if (!cur2)
-	return 1;
+    return cmp;
+}
 
-    retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
+/*
+=for apidoc sv_cmp_locale
 
-    if (retval)
-	return retval < 0 ? -1 : 1;
+Compares the strings in two SVs in a locale-aware manner. See
+L</sv_cmp_locale>
 
-    if (cur1 == cur2)
-	return 0;
-    else
-	return cur1 < cur2 ? -1 : 1;
-}
+=cut
+*/
 
 I32
 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
@@ -4222,6 +4324,15 @@ Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
 
 #endif /* USE_LOCALE_COLLATE */
 
+/*
+=for apidoc sv_gets
+
+Get a line from the filehandle and store it into the SV, optionally
+appending to the currently-stored string.
+
+=cut
+*/
+
 char *
 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
 {
@@ -5128,6 +5239,14 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
     }
 }
 
+/*
+=for apidoc sv_true
+
+Returns true if the SV has a true value by Perl's rules.
+
+=cut
+*/
+
 I32
 Perl_sv_true(pTHX_ register SV *sv)
 {
@@ -5206,6 +5325,14 @@ Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
     return sv_2pv(sv, lp);
 }
 
+/*
+=for apidoc sv_pvn_force
+
+Get a sensible string out of the SV somehow.
+
+=cut
+*/
+
 char *
 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
 {
@@ -5278,6 +5405,15 @@ Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
     return sv_pvn(sv,lp);
 }
 
+/*
+=for apidoc sv_pvutf8n_force
+
+Get a sensible UTF8-encoded string out of the SV somehow. See
+L</sv_pvn_force>.
+
+=cut
+*/
+
 char *
 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
 {
@@ -5285,6 +5421,14 @@ Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
     return sv_pvn_force(sv,lp);
 }
 
+/*
+=for apidoc sv_reftype
+
+Returns a string describing what the SV is a reference to.
+
+=cut
+*/
+
 char *
 Perl_sv_reftype(pTHX_ SV *sv, int ob)
 {
@@ -5963,17 +6107,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    case 'v':
 		vectorize = TRUE;
 		q++;
-		if (args)
-		    vecsv = va_arg(*args, SV*);
-		else if (svix < svmax)
-		    vecsv = svargs[svix++];
-		else {
-		    vecstr = (U8*)"";
-		    veclen = 0;
-		    continue;
-		}
-		vecstr = (U8*)SvPVx(vecsv,veclen);
-		utf = DO_UTF8(vecsv);
 		continue;
 
 	    default:
@@ -6024,6 +6157,23 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    has_precis = TRUE;
 	}
 
+	if (vectorize) {
+	    if (args) {
+		vecsv = va_arg(*args, SV*);
+		vecstr = (U8*)SvPVx(vecsv,veclen);
+		utf = DO_UTF8(vecsv);
+	    }
+	    else if (svix < svmax) {
+		vecsv = svargs[svix++];
+		vecstr = (U8*)SvPVx(vecsv,veclen);
+		utf = DO_UTF8(vecsv);
+	    }
+	    else {
+		vecstr = (U8*)"";
+		veclen = 0;
+	    }
+	}
+
 	/* SIZE */
 
 	switch (*q) {
@@ -6133,6 +6283,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    /* INTEGERS */
 
 	case 'p':
+	    if (alt)
+		goto unknown;
 	    if (args)
 		uv = PTR2UV(va_arg(*args, void*));
 	    else
@@ -6429,7 +6581,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		}
 	    }
 	    else if (svix < svmax)
-		sv_setuv(svargs[svix++], (UV)i);
+		sv_setuv_mg(svargs[svix++], (UV)i);
 	    continue;	/* not "break" */
 
 	    /* UNKNOWN */