handle reading from a SVf_UTF8 scalar

if the scalar can be downgradable, it is downgraded and the read succeeds.

Otherwise the read fails, producing a warning if enabled and setting
errno/$! to EINVAL.

2 files changed, 17 insertions, 7 deletions

diff --git a/ext/PerlIO-scalar/scalar.xs b/ext/PerlIO-scalar/scalar.xs
index d7c7ef69bb..3be9944fcb 100644
--- a/ext/PerlIO-scalar/scalar.xs
+++ b/ext/PerlIO-scalar/scalar.xs
@@ -6,6 +6,9 @@
 
 #include "perliol.h"
 
+static const char code_point_warning[] =
+ "Strings with code points over 0xFF may not be mapped into in-memory file handles\n";
+
 typedef struct {
     struct _PerlIO base;	/* Base "class" info */
     SV *var;
@@ -54,7 +57,7 @@ PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
     }
     if (SvUTF8(s->var) && !sv_utf8_downgrade(s->var, TRUE)) {
 	if (ckWARN(WARN_UTF8))
-	    Perl_warner(aTHX_ packWARN(WARN_UTF8), "Strings with code points over 0xFF may not be mapped into in-memory file handles\n");
+	    Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
 	SETERRNO(EINVAL, SS_IVCHAN);
 	SvREFCNT_dec(s->var);
 	s->var = Nullsv;
@@ -151,6 +154,17 @@ PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 	STRLEN len;
 	I32 got;
 	p = SvPV(sv, len);
+	if (SvUTF8(sv)) {
+	    if (sv_utf8_downgrade(sv, TRUE)) {
+	        p = SvPV_nomg(sv, len);
+	    }
+	    else {
+	        if (ckWARN(WARN_UTF8))
+		    Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
+	        SETERRNO(EINVAL, SS_IVCHAN);
+	        return -1;
+	    }
+	}
 	got = len - (STRLEN)(s->posn);
 	if (got <= 0)
 	    return 0;
diff --git a/ext/PerlIO-scalar/t/scalar.t b/ext/PerlIO-scalar/t/scalar.t
index 2280fe03f6..3be26c5c8c 100644
--- a/ext/PerlIO-scalar/t/scalar.t
+++ b/ext/PerlIO-scalar/t/scalar.t
@@ -414,14 +414,13 @@ my $byte_warning = "Strings with code points over 0xFF may not be mapped into in
 }
 { # changes after open
     my $content = "abc";
-    ok(open(my $fh, "<", \$content), "open a scalar");
+    ok(open(my $fh, "+<", \$content), "open a scalar");
     my $tmp;
     is(read($fh, $tmp, 1), 1, "basic read");
     seek($fh, 1, SEEK_SET);
     $content = "\xA1\xA2\xA3";
     utf8::upgrade($content);
     is(read($fh, $tmp, 1), 1, "read from post-open upgraded scalar");
-    local $TODO = "read doesn't handle a post open non-byte scalar";
     is($tmp, "\xA2", "check we read the correct value");
     seek($fh, 1, SEEK_SET);
     $content = "\x{101}\x{102}\x{103}";
@@ -432,10 +431,7 @@ my $byte_warning = "Strings with code points over 0xFF may not be mapped into in
     $! = 0;
     is(read($fh, $tmp, 1), undef, "read from scalar with >0xff chars");
     is(0+$!, EINVAL, "check errno set correctly");
-    {
-        local $TODO;
-	is_deeply(\@warnings, [], "should be no warning (yet)");
-    }
+    is_deeply(\@warnings, [], "should be no warning (yet)");
     use warnings "utf8";
     seek($fh, 1, SEEK_SET);
     is(read($fh, $tmp, 1), undef, "read from scalar with >0xff chars");