From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Wed, 10 Sep 2003 06:57:16 +0000 (+0000)
Subject: [perl #23770] Reading a latin1 file with open(... "<:utf8") will freeze
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d3b4e16f4348ab55ddb8e9e8a4e27b46567d2855;p=p5sagit%2Fp5-mst-13.2.git

[perl #23770] Reading a latin1 file with open(... "<:utf8") will freeze
is no more valid, the script doesn't freeze, but I noticed
that neither does the <FILE> complain about bad UTF-8 as it
should and as it does with :encoding(utf8).

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

diff --git a/pp_hot.c b/pp_hot.c
index 0851ab8..1de483c 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1569,6 +1569,16 @@ Perl_do_readline(pTHX)
 	    MAYBE_TAINT_LINE(io, sv);
 	    RETURN;
 	}
+	if (SvUTF8(sv)) {
+	     U8 *f;
+
+	     if (ckWARN(WARN_UTF8) &&
+		 !Perl_is_utf8_string_loc(aTHX_ (U8*)SvPVX(sv), SvCUR(sv), &f))
+		  /* Emulate :encoding(utf8) warning in the same case. */
+		  Perl_warner(aTHX_ packWARN(WARN_UTF8),
+			      "utf8 \"\\x%02X\" does not map to Unicode",
+			      f < (U8*)SvEND(sv) ? *f : 0);
+	}
 	MAYBE_TAINT_LINE(io, sv);
 	IoLINES(io)++;
 	IoFLAGS(io) |= IOf_NOLINE;
diff --git a/t/io/utf8.t b/t/io/utf8.t
index 50cc012..aade3bd 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 => 51);
+plan(tests => 52);
 
 $| = 1;
 
@@ -306,15 +306,28 @@ ok( 1 );
     open F, ">a";
     binmode F, ":utf8";
     syswrite(F, $a = chr(0x100));
-    close A;
+    close F;
     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
 
+{
+    # <FH> on a :utf8 stream should complain immediately
+    # if it finds bad UTF-8 (:encoding(utf8) works this way)
+    local $SIG{__WARN__} = sub { $@ = shift };
+    open F, ">a";
+    binmode F;
+    print F "foo", chr(0xE4), "\n";
+    close F;
+    open F, "<:utf8", "a";
+    my $line = <F>;
+    like( $@, qr/utf8 "\\xE4" does not map to Unicode/ );
+    close F;
+}
+
 END {
     1 while unlink "a";
     1 while unlink "b";
 }
-