Re: 5.6.*, bleadperl: bugs in pp_concat

Message-Id: <200105261605.RAA12295@crypt.compulink.co.uk>

p4raw-id: //depot/perl@10223

1 files changed, 133 insertions, 31 deletions

diff --git a/sv.c b/sv.c
index d8527126a7..7b53a43d1a 100644
--- a/sv.c
+++ b/sv.c
@@ -2643,6 +2643,12 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
 char *
 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
 {
+    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 +2660,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 +2972,25 @@ if all the bytes have hibit clear.
 STRLEN
 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 {
+    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 +2999,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;
     }
@@ -3149,9 +3175,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 +3352,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);
@@ -3833,21 +3880,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 +3943,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);
     }
 }
 
@@ -6168,6 +6253,23 @@ Get a sensible string out of the SV somehow.
 char *
 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
 {
+    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 +6284,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;