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.

diff --git a/ext/PerlIO-scalar/scalar.xs b/ext/PerlIO-scalar/scalar.xs
index d7c7ef6..3be9944 100644 (file)
--- 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 2280fe0..3be26c5 100644 (file)
--- 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");