The sv_catsv() fix, take two.

p4raw-id: //depot/perl@8265

diff --git a/sv.c b/sv.c
index 4794596..662b974 100644 (file)
--- 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
 
 /*
 =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)
 {
 
 void
 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
 {

-    char *s;
-    STRLEN len;
+    char *spv;
+    STRLEN slen;

     if (!sstr)
        return;
     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 (executable)
--- a/t/op/join.t
+++ b/t/op/join.t
@@ -1,6 +1,6 @@
 #!./perl
 
 #!./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";}
 
 @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";
 };
   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";
+}
+