In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/a951350815de819cc1155e2ffc3f78a5841d793e?hp=0865247fee6a3b07e9b17ec10a45c3426d101b56>
- Log ----------------------------------------------------------------- commit a951350815de819cc1155e2ffc3f78a5841d793e Merge: 0865247 eeee3e0 Author: Tony Cook <[email protected]> Date: Fri Jan 25 10:42:37 2013 +1100 [perl #109828] disallow scalar I/O on non-byte strings commit eeee3e08815574e8ff5230ee3e0c74f00b1791fb Author: Tony Cook <[email protected]> Date: Thu Jan 24 21:37:25 2013 +1100 warn and fail on writes to SVf_UTF8 SVs M ext/PerlIO-scalar/scalar.xs M ext/PerlIO-scalar/t/scalar.t commit f07ca60cafb35d8601b5bd0da0a7383231de5fec Author: Tony Cook <[email protected]> Date: Fri Jan 25 09:56:14 2013 +1100 TODO tests for writing to a SVf_UTF8 scalar M ext/PerlIO-scalar/t/scalar.t commit b38d579d7e4fdb6e4abade72630ea777d8c509d9 Author: Tony Cook <[email protected]> Date: Fri Jan 25 09:56:01 2013 +1100 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. M ext/PerlIO-scalar/scalar.xs M ext/PerlIO-scalar/t/scalar.t commit 52879d7fcf9b398e46a3b65c2fd169e3ec26f2f7 Author: Tony Cook <[email protected]> Date: Mon Dec 31 13:33:02 2012 +1100 TODO tests for reads from a scalar changed to upgraded after open M ext/PerlIO-scalar/t/scalar.t commit 99da03e646c09b00152355b90c896c8183bdfcfb Author: Tony Cook <[email protected]> Date: Mon Dec 31 11:48:24 2012 +1100 bump PerlIO::scalar's version M ext/PerlIO-scalar/scalar.pm commit 1693fdbb93a2eb11f69263ad768b0366ba3f5e09 Author: Tony Cook <[email protected]> Date: Thu Jan 24 14:38:21 2013 +1100 document the new warning M pod/perldiag.pod commit 02c3c86bb8fe791df9608437f0844f9a8017e3b6 Author: Tony Cook <[email protected]> Date: Thu Jan 24 21:29:32 2013 +1100 fail to open scalars containing characters that don't fit in a byte M ext/PerlIO-scalar/scalar.xs M ext/PerlIO-scalar/t/scalar.t commit 7af8b2b665219f5a659f71baed751d45e54801e7 Author: Tony Cook <[email protected]> Date: Thu Jan 24 14:35:25 2013 +1100 TODO tests for opening upgraded scalars M ext/PerlIO-scalar/t/scalar.t ----------------------------------------------------------------------- Summary of changes: ext/PerlIO-scalar/scalar.pm | 2 +- ext/PerlIO-scalar/scalar.xs | 28 +++++++++++++++ ext/PerlIO-scalar/t/scalar.t | 78 +++++++++++++++++++++++++++++++++++++++++- pod/perldiag.pod | 6 +++ 4 files changed, 112 insertions(+), 2 deletions(-) diff --git a/ext/PerlIO-scalar/scalar.pm b/ext/PerlIO-scalar/scalar.pm index 813f5e6..64ecc22 100644 --- a/ext/PerlIO-scalar/scalar.pm +++ b/ext/PerlIO-scalar/scalar.pm @@ -1,5 +1,5 @@ package PerlIO::scalar; -our $VERSION = '0.15'; +our $VERSION = '0.16'; require XSLoader; XSLoader::load(); 1; diff --git a/ext/PerlIO-scalar/scalar.xs b/ext/PerlIO-scalar/scalar.xs index d7b8828..e7e8330 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; @@ -52,6 +55,14 @@ PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, sv_force_normal(s->var); SvCUR_set(s->var, 0); } + if (SvUTF8(s->var) && !sv_utf8_downgrade(s->var, TRUE)) { + if (ckWARN(WARN_UTF8)) + Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning); + SETERRNO(EINVAL, SS_IVCHAN); + SvREFCNT_dec(s->var); + s->var = Nullsv; + return -1; + } if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) { sv_force_normal(s->var); @@ -143,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; @@ -165,6 +187,12 @@ PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count) SvGETMAGIC(sv); if (!SvROK(sv)) sv_force_normal(sv); if (SvOK(sv)) SvPV_force_nomg_nolen(sv); + if (SvUTF8(sv) && !sv_utf8_downgrade(sv, TRUE)) { + if (ckWARN(WARN_UTF8)) + Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning); + SETERRNO(EINVAL, SS_IVCHAN); + return 0; + } if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) { dst = SvGROW(sv, SvCUR(sv) + count + 1); offset = SvCUR(sv); diff --git a/ext/PerlIO-scalar/t/scalar.t b/ext/PerlIO-scalar/t/scalar.t index d255a05..d6bd8cf 100644 --- a/ext/PerlIO-scalar/t/scalar.t +++ b/ext/PerlIO-scalar/t/scalar.t @@ -16,7 +16,7 @@ use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere. $| = 1; -use Test::More tests => 82; +use Test::More tests => 108; my $fh; my $var = "aaa\n"; @@ -384,3 +384,79 @@ SKIP: { close FILE; is $content, "Foo-Bar\n", 'duping via >&='; } + +# [perl #109828] PerlIO::scalar does not handle UTF-8 +my $byte_warning = "Strings with code points over 0xFF may not be mapped into in-memory file handles\n"; +{ + use Errno qw(EINVAL); + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, "@_" }; + my $content = "12\x{101}"; + $! = 0; + ok(!open(my $fh, "<", \$content), "non-byte open should fail"); + is(0+$!, EINVAL, "check \$! is updated"); + is_deeply(\@warnings, [], "should be no warnings (yet)"); + use warnings "utf8"; + $! = 0; + ok(!open(my $fh, "<", \$content), "non byte open should fail (and warn)"); + is(0+$!, EINVAL, "check \$! is updated even when we warn"); + is_deeply(\@warnings, [ $byte_warning ], "should have warned"); + + @warnings = (); + $content = "12\xA1"; + utf8::upgrade($content); + ok(open(my $fh, "<", \$content), "open upgraded scalar"); + my $tmp; + is(read($fh, $tmp, 4), 3, "read should get the downgraded bytes"); + is($tmp, "12\xA1", "check we got the expected bytes"); + close $fh; + is_deeply(\@warnings, [], "should be no more warnings"); +} +{ # changes after open + my $content = "abc"; + 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"); + is($tmp, "\xA2", "check we read the correct value"); + seek($fh, 1, SEEK_SET); + $content = "\x{101}\x{102}\x{103}"; + + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, "@_" }; + + $! = 0; + is(read($fh, $tmp, 1), undef, "read from scalar with >0xff chars"); + is(0+$!, EINVAL, "check errno set correctly"); + 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"); + is_deeply(\@warnings, [ $byte_warning ], "check warning"); + + select $fh; # make sure print fails rather tha buffers + $| = 1; + select STDERR; + no warnings "utf8"; + @warnings = (); + $content = "\xA1\xA2\xA3"; + utf8::upgrade($content); + seek($fh, 1, SEEK_SET); + ok((print $fh "A"), "print to an upgraded byte string"); + seek($fh, 1, SEEK_SET); + is($content, "\xA1A\xA3", "check result"); + + $content = "\x{101}\x{102}\x{103}"; + $! = 0; + ok(!(print $fh "B"), "write to an non-downgradable SV"); + is(0+$!, EINVAL, "check errno set"); + + is_deeply(\@warnings, [], "should be no warning"); + + use warnings "utf8"; + ok(!(print $fh "B"), "write to an non-downgradable SV (and warn)"); + is_deeply(\@warnings, [ $byte_warning ], "check warning"); +} diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 797bb8e..fadbbad 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -3410,6 +3410,12 @@ call, or call a constructor from the FileHandle package. (W unopened) You tried to invoke a file test operator on a filehandle that isn't open. Check your control flow. See also L<perlfunc/-X>. +=item Strings with code points over 0xFF may not be mapped into in-memory file handles + +(W utf8) You tried to open a reference to a scalar for read or append +where the scalar contained code points over 0xFF. In-memory files +model on-disk files and can only contain bytes. + =item oops: oopsAV (S internal) An internal warning that the grammar is screwed up. -- Perl5 Master Repository
