From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 29 Apr 2006 17:38:08 +0000 (+0000)
Subject: print couldn't correctly handle surprises from UTF-8 overloading.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=676f44e7e401461aa81575a0e3d8e005bbe94251;p=p5sagit%2Fp5-mst-13.2.git

print couldn't correctly handle surprises from UTF-8 overloading.

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

diff --git a/doio.c b/doio.c
index b49eec3..507a855 100644
--- a/doio.c
+++ b/doio.c
@@ -1227,6 +1227,8 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
     dVAR;
     register const char *tmps;
     STRLEN len;
+    U8 *tmpbuf = NULL;
+    bool happy = TRUE;
 
     /* assuming fp is checked earlier */
     if (!sv)
@@ -1247,19 +1249,32 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
 	}
 	/* FALL THROUGH */
     default:
+	/* Do this first to trigger any overloading.  */
+	tmps = SvPV_const(sv, len);
 	if (PerlIO_isutf8(fp)) {
-	    if (!SvUTF8(sv))
-		sv_utf8_upgrade_flags(sv = sv_mortalcopy(sv),
-				      SV_GMAGIC|SV_UTF8_NO_ENCODING);
+	    if (!SvUTF8(sv)) {
+		/* We don't modify the original scalar.  */
+		tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
+		tmps = (char *) tmpbuf;
+	    }
 	}
 	else if (DO_UTF8(sv)) {
-	    if (!sv_utf8_downgrade((sv = sv_mortalcopy(sv)), TRUE)
-		&& ckWARN_d(WARN_UTF8))
-	    {
-		Perl_warner(aTHX_ packWARN(WARN_UTF8), "Wide character in print");
+	    STRLEN tmplen = len;
+	    bool utf8 = TRUE;
+	    U8 *result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
+	    if (!utf8) {
+		tmpbuf = result;
+		tmps = (char *) tmpbuf;
+		len = tmplen;
+	    }
+	    else {
+		assert((char *)result == tmps);
+		if (ckWARN_d(WARN_UTF8)) {
+		    Perl_warner(aTHX_ packWARN(WARN_UTF8),
+				"Wide character in print");
+		}
 	    }
 	}
-	tmps = SvPV_const(sv, len);
 	break;
     }
     /* To detect whether the process is about to overstep its
@@ -1269,8 +1284,10 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
      * at which we would get EPERM.  Note that when using buffered
      * io the write failure can be delayed until the flush/close. --jhi */
     if (len && (PerlIO_write(fp,tmps,len) == 0))
-	return FALSE;
-    return !PerlIO_error(fp);
+	happy = FALSE;
+    if (tmpbuf)
+	Safefree(tmpbuf);
+    return happy ? !PerlIO_error(fp) : FALSE;
 }
 
 I32
diff --git a/t/uni/overload.t b/t/uni/overload.t
index 95c916a..478544c 100644
--- a/t/uni/overload.t
+++ b/t/uni/overload.t
@@ -7,7 +7,7 @@ BEGIN {
     }
 }
 
-use Test::More tests => 56;
+use Test::More tests => 68;
 
 package UTF8Toggle;
 use strict;
@@ -16,7 +16,9 @@ use overload '""' => 'stringify';
 
 sub new {
     my $class = shift;
-    return bless [shift, 0], $class;
+    my $value = shift;
+    my $state = shift||0;
+    return bless [$value, $state], $class;
 }
 
 sub stringify {
@@ -146,3 +148,42 @@ SKIP: {
 	is ($uc, "\311", "e accute -> E accute");
     }
 }
+
+my $tmpfile = 'overload.tmp';
+
+foreach my $operator (qw (print)) {
+    foreach my $layer ('', ':utf8') {
+	open my $fh, "+>$layer", $tmpfile or die $!;
+	my $u = UTF8Toggle->new("\311\n");
+	print $fh $u;
+	print $fh $u;
+	print $fh $u;
+	my $l = UTF8Toggle->new("\351\n", 1);
+	print $fh $l;
+	print $fh $l;
+	print $fh $l;
+
+	seek $fh, 0, 0 or die $!;
+	my $line;
+	chomp ($line = <$fh>);
+	is ($line, "\311", "$operator $layer");
+	chomp ($line = <$fh>);
+	is ($line, "\311", "$operator $layer");
+	chomp ($line = <$fh>);
+	is ($line, "\311", "$operator $layer");
+	chomp ($line = <$fh>);
+	is ($line, "\351", "$operator $layer");
+	chomp ($line = <$fh>);
+	is ($line, "\351", "$operator $layer");
+	chomp ($line = <$fh>);
+	is ($line, "\351", "$operator $layer");
+
+	close $fh or die $!;
+	unlink $tmpfile or die $!;
+    }
+}
+
+
+END {
+    1 while -f $tmpfile and unlink $tmpfile || die "unlink '$tmpfile': $!";
+}