From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Thu, 21 Aug 2003 18:09:10 +0000 (+0000)
Subject: Fix the syswrite downgrade bug of
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4de5f5caa29d6a57b47c489616e3eb1627496091;p=p5sagit%2Fp5-mst-13.2.git

Fix the syswrite downgrade bug of
[perl #23428] Somethings rotten in unicode semantics

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

diff --git a/pp_sys.c b/pp_sys.c
index d8dc103..f35bc8a 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1807,9 +1807,12 @@ PP(pp_send)
 	buffer = SvPVutf8(bufsv, blen);
     }
     else {
-	if (DO_UTF8(bufsv))
-	    sv_utf8_downgrade(bufsv, FALSE);
-	buffer = SvPV(bufsv, blen);
+	 if (DO_UTF8(bufsv)) {
+	      /* Not modifying source SV, so making a temporary copy. */
+	      bufsv = sv_2mortal(newSVsv(bufsv));
+	      sv_utf8_downgrade(bufsv, FALSE);
+	 }
+	 buffer = SvPV(bufsv, blen);
     }
 
     if (PL_op->op_type == OP_SYSWRITE) {
diff --git a/t/io/utf8.t b/t/io/utf8.t
index 6a24c51..6b189ee 100755
--- a/t/io/utf8.t
+++ b/t/io/utf8.t
@@ -13,7 +13,7 @@ no utf8; # needed for use utf8 not griping about the raw octets
 
 require "./test.pl";
 
-plan(tests => 49);
+plan(tests => 51);
 
 $| = 1;
 
@@ -301,6 +301,15 @@ ok( 1 );
     # last test here 49
 }
 
+{
+    # [perl #23428] Somethings rotten in unicode semantics
+    open F, ">a";
+    binmode F, ":utf8";
+    syswrite(F, $a = chr(0x100));
+    is( ord($a), 0x100, '23428 syswrite should not downgrade scalar' );
+    like( $a, qr/^\w+/, '23428 syswrite should not downgrade scalar' );
+}
+
 # sysread() and syswrite() tested in lib/open.t since Fcntl is used
 
 END {