From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Sat, 30 Dec 2000 07:28:55 +0000 (+0000)
Subject: The sv_catsv() fix, take two.
X-Git-Tag: perl-5.7.1~865
X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/13e8c8e316d3839d0834fb8b851566b00d81e876

The sv_catsv() fix, take two.

p4raw-id: //depot/perl@8265
---

diff --git a/sv.c b/sv.c
index 4794596..662b974 100644
--- a/sv.c
+++ b/sv.c
@@ -3748,27 +3748,42 @@ Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRL
 /*
 =for apidoc sv_catsv
 
-Concatenates the string from SV C<ssv> onto the end of the string in SV
-C<dsv>.  Handles 'get' magic, but not 'set' magic.  See C<sv_catsv_mg>.
+Concatenates the string from SV C<ssv> onto the end of the string in
+SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
+not 'set' magic.  See C<sv_catsv_mg>.
 
-=cut
-*/
+=cut */
 
 void
 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
 {
-    char *s;
-    STRLEN len;
+    char *spv;
+    STRLEN slen;
     if (!sstr)
 	return;
-    if ((s = SvPV(sstr, len))) {
-	if (DO_UTF8(sstr)) {
-	    sv_utf8_upgrade(dstr);
-	    sv_catpvn(dstr,s,len);
-	    SvUTF8_on(dstr);
+    if ((spv = SvPV(sstr, slen))) {
+	bool dutf8 = DO_UTF8(dstr);
+	bool sutf8 = DO_UTF8(sstr);
+
+	if (dutf8 == sutf8)
+	    sv_catpvn(dstr,spv,slen);
+	else {
+	    if (dutf8) {
+		SV* cstr = newSVsv(sstr);
+		char *cpv;
+		STRLEN clen;
+
+		sv_utf8_upgrade(cstr);
+		cpv = SvPV(cstr,clen);
+		sv_catpvn(dstr,cpv,clen);
+		sv_2mortal(cstr);
+	    }
+	    else {
+		sv_utf8_upgrade(dstr);
+		sv_catpvn(dstr,spv,slen);
+		SvUTF8_on(dstr);
+	    }
 	}
-	else
-	    sv_catpvn(dstr,s,len);
     }
 }
 
diff --git a/t/op/join.t b/t/op/join.t
index b50878e..0f849fd 100755
--- a/t/op/join.t
+++ b/t/op/join.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..10\n";
+print "1..14\n";
 
 @x = (1, 2, 3);
 if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
@@ -44,3 +44,24 @@ if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";}
   print "# expected 'a17b21c' got '$r'\nnot " if $r ne 'a17b21c';
   print "ok 10\n";
 };
+
+{ my $s = join("", chr(0x1234), chr(0xff));
+  print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}";
+  print "ok 11\n";
+}
+
+{ my $s = join(chr(0xff), chr(0x1234), "");
+  print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}";
+  print "ok 12\n";
+}
+
+{ my $s = join(chr(0x1234), chr(0xff), chr(0x2345));
+  print "not " unless length($s) == 3 && $s eq "\x{ff}\x{1234}\x{2345}";
+  print "ok 13\n";
+}
+
+{ my $s = join(chr(0xff), chr(0x1234), chr(0xfe));
+  print "not " unless length($s) == 3 && $s eq "\x{1234}\x{ff}\x{fe}";
+  print "ok 14\n";
+}
+