rpms/perl
7
0
Fork 0
Code Issues Pull Requests Releases Activity

Fix thread-safety of IO::Handle

Browse Source
This commit is contained in:
Petr Písař 2020-03-27 14:56:31 +01:00
parent 9d89f109e7
commit 66c9bf33c3
4 changed files with 531 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

272
perl-5.30.2-Loading-IO-is-now-threadsafe-avoiding-the-core-bug-r.patch Normal file
View File

@ -0,0 +1,272 @@
From 1c8a3be06814f8b86459ad53b2f903fd50c4c4d8 Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Mon, 4 Nov 2019 16:58:03 +0100
Subject: [PATCH] Loading IO is now threadsafe, avoiding the core bug reported
as GH #14816.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Re-implement getline() and getlines() as XS code.
The underlying problem that we're trying to solve here is making
getline() and getlines() in IO::Handle respect the open pragma.
That bug was first addressed in Sept 2011 by commit 986a805c4b258067:
Make IO::Handle::getline(s) respect the open pragma
However, that fix introduced a more subtle bug, hence this reworking.
Including the entirety of the rest of that commit message because it
explains both the bug the previous approach:
See <https://rt.cpan.org/Ticket/Display.html?id=66474>. Also, this
came up in <https://rt.perl.org/rt3/Ticket/Display.html?id=92728>.
The <> operator, when reading from the magic ARGV handle, automatic-
ally opens the next file. Layers set by the lexical open pragma are
applied, if they are in scope at the point where <> is used.
This works almost all the time, because the common convention is:
use open ":utf8";
while(<>) {
...
}
IO::Handle’s getline and getlines methods are Perl subroutines
that call <> themselves. But that happens within the scope of
IO/Handle.pm, so the caller’s I/O layer settings are ignored. That
means that these two expressions are not equivalent within in a
‘use open’ scope:
<>
*ARGV->getline
The latter will open the next file with no layers applied.
This commit solves that by putting PL_check hooks in place in
IO::Handle before compiling the getline and getlines subroutines.
Those hooks cause every state op (nextstate, or dbstate under the
debugger) to have a custom pp function that saves the previous value
of PL_curcop, calls the default pp function, and then restores
PL_curcop.
That means that getline and getlines run with the caller’s compile-
time hints. Another way to see it is that getline and getlines’s own
lexical hints are never activated.
(A state op carries all the lexical pragmata. Every statement
has one. When any op executes, it’s ‘pp’ function is called.
pp_nextstate and pp_dbstate both set PL_curcop to the op itself. Any
code that checks hints looks at PL_curcop, which contains the current
run-time hints.)
The problem with this approach is that the (current) design and implementation
of PL_check hooks is actually not threadsafe. There's one array (as a global),
which is used by all interpreters in the process. But as the code added to
IO.xs demonstrates, realistically it needs to be possible to change the hook
just for this interpreter.
GH #14816 has a fix for that bug for blead. However, it will be tricky (to
impossible) to backport to earlier perl versions.
Hence it's also worthwhile to change IO.xs to use a different approach to
solve the original bug. As described above, the bug is fixed by having the
readline OP (that implements getline() and getlines()) see the caller's
lexical state, not their "own". Unlike Perl subroutines, XS subroutines don't
have any lexical hints of their own. getline() and getlines() are very
simple, mostly parameter checking, ending with a one line that maps to
a single core OP, whose values are directly returned.
Hence "all" we need to do re-implement the Perl code as XS. This might look
easy, but turns out to be trickier than expected. There isn't any API to be
called for the OP in question, pp_readline(). The body of the OP inspects
interpreter state, it directly calls pp_rv2gv() which also inspects state,
and then it tail calls Perl_do_readline(), which inspects state.
The easiest approach seems to be to set up enough state, and then call
pp_readline() directly. This leaves us very tightly coupled to the
internals, but so do all other approaches to try to tackle this bug.
The current implementation of PL_check (and possibly other arrays) still
needs to be addressed.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
META.json | 1 +
META.yml | 1 +
dist/IO/IO.xs | 93 +++++++++++++++++++++++++++-------------
dist/IO/lib/IO/Handle.pm | 20 ---------
4 files changed, 66 insertions(+), 49 deletions(-)
diff --git a/META.json b/META.json
index e023606..53c1e79 100644
--- a/META.json
+++ b/META.json
@@ -86,6 +86,7 @@
"dist/IO/t/io_dup.t",
"dist/IO/t/io_file.t",
"dist/IO/t/io_file_export.t",
+ "dist/IO/t/io_getline.t",
"dist/IO/t/io_leak.t",
"dist/IO/t/io_linenum.t",
"dist/IO/t/io_multihomed.t",
diff --git a/META.yml b/META.yml
index 85fb097..f71108e 100644
--- a/META.yml
+++ b/META.yml
@@ -83,6 +83,7 @@ no_index:
- dist/IO/t/io_dup.t
- dist/IO/t/io_file.t
- dist/IO/t/io_file_export.t
+ - dist/IO/t/io_getline.t
- dist/IO/t/io_leak.t
- dist/IO/t/io_linenum.t
- dist/IO/t/io_multihomed.t
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
index 8e857f8..68b7352 100644
--- a/dist/IO/IO.xs
+++ b/dist/IO/IO.xs
@@ -185,26 +185,6 @@ io_blocking(pTHX_ InputStream f, int block)
#endif
}
-static OP *
-io_pp_nextstate(pTHX)
-{
- dVAR;
- COP *old_curcop = PL_curcop;
- OP *next = PL_ppaddr[PL_op->op_type](aTHX);
- PL_curcop = old_curcop;
- return next;
-}
-
-static OP *
-io_ck_lineseq(pTHX_ OP *o)
-{
- OP *kid = cBINOPo->op_first;
- for (; kid; kid = OpSIBLING(kid))
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
- kid->op_ppaddr = io_pp_nextstate;
- return o;
-}
-
MODULE = IO PACKAGE = IO::Seekable PREFIX = f
@@ -558,16 +538,71 @@ fsync(arg)
OUTPUT:
RETVAL
-SV *
-_create_getline_subs(const char *code)
- CODE:
- OP *(*io_old_ck_lineseq)(pTHX_ OP *) = PL_check[OP_LINESEQ];
- PL_check[OP_LINESEQ] = io_ck_lineseq;
- RETVAL = SvREFCNT_inc(eval_pv(code,FALSE));
- PL_check[OP_LINESEQ] = io_old_ck_lineseq;
- OUTPUT:
- RETVAL
+# To make these two work correctly with the open pragma, the readline op
+# needs to pick up the lexical hints at the method's callsite. This doesn't
+# work in pure Perl, because the hints are read from the most recent nextstate,
+# and the nextstate of the Perl subroutines show *here* hold the lexical state
+# for the IO package.
+#
+# There's no clean way to implement this - this approach, while complex, seems
+# to be the most robust, and avoids manipulating external state (ie op checkers)
+#
+# sub getline {
+# @_ == 1 or croak 'usage: $io->getline()';
+# my $this = shift;
+# return scalar <$this>;
+# }
+#
+# sub getlines {
+# @_ == 1 or croak 'usage: $io->getlines()';
+# wantarray or
+# croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
+# my $this = shift;
+# return <$this>;
+# }
+
+# If this is deprecated, should it warn, and should it be removed at some point?
+# *gets = \&getline; # deprecated
+void
+getlines(...)
+ALIAS:
+ IO::Handle::getline = 1
+ IO::Handle::gets = 2
+INIT:
+ UNOP myop;
+ SV *io;
+ OP *was = PL_op;
+PPCODE:
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: $io->%s()", ix ? "getline" : "getlines");
+ if (!ix && GIMME_V != G_ARRAY)
+ Perl_croak(aTHX_ "Can't call $io->getlines in a scalar context, use $io->getline");
+ Zero(&myop, 1, UNOP);
+ myop.op_flags = (ix ? OPf_WANT_SCALAR : OPf_WANT_LIST ) | OPf_STACKED;
+ myop.op_ppaddr = PL_ppaddr[OP_READLINE];
+ myop.op_type = OP_READLINE;
+ /* I don't know if we need this, but it's correct as far as the control flow
+ goes. However, if we *do* need it, do we need to set anything else up? */
+ myop.op_next = PL_op->op_next;
+ /* Sigh, because pp_readline calls pp_rv2gv, and *it* has this wonderful
+ state check for PL_op->op_type == OP_READLINE */
+ PL_op = (OP *) &myop;
+ io = ST(0);
+ /* Our target (which we need to provide, as we don't have a pad entry.
+ I think that this is only needed for G_SCALAR - maybe we can get away
+ with NULL for list context? */
+ PUSHs(sv_newmortal());
+ XPUSHs(io);
+ PUTBACK;
+ /* And effectively we get away with tail calling pp_readline, as it stacks
+ exactly the return value(s) we need to return. */
+ PL_ppaddr[OP_READLINE](aTHX);
+ PL_op = was;
+ /* And we don't want to reach the line
+ PL_stack_sp = sp;
+ that xsubpp adds after our body becase PL_stack_sp is correct, not sp */
+ return;
MODULE = IO PACKAGE = IO::Socket
diff --git a/dist/IO/lib/IO/Handle.pm b/dist/IO/lib/IO/Handle.pm
index a257024..d48a4d1 100644
--- a/dist/IO/lib/IO/Handle.pm
+++ b/dist/IO/lib/IO/Handle.pm
@@ -431,26 +431,6 @@ sub say {
print $this @_;
}
-# Special XS wrapper to make them inherit lexical hints from the caller.
-_create_getline_subs( <<'END' ) or die $@;
-sub getline {
- @_ == 1 or croak 'usage: $io->getline()';
- my $this = shift;
- return scalar <$this>;
-}
-
-sub getlines {
- @_ == 1 or croak 'usage: $io->getlines()';
- wantarray or
- croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
- my $this = shift;
- return <$this>;
-}
-1; # return true for error checking
-END
-
-*gets = \&getline; # deprecated
-
sub truncate {
@_ == 2 or croak 'usage: $io->truncate(LEN)';
truncate($_[0], $_[1]);
--
2.21.1

200
perl-5.31.7-Add-tests-for-IO-Handle-getline-and-getlines.patch Normal file
View File

@ -0,0 +1,200 @@
From 7a992ccc8be4ce4c27268e1980edb4701f9948d9 Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Sun, 3 Nov 2019 11:06:59 +0100
Subject: [PATCH] Add tests for IO::Handle getline() and getlines().
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Extend the tests for <> and the open pragma to verify that the behaviour
changes with/without the open pragma.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
MANIFEST | 1 +
dist/IO/README | 1 -
dist/IO/t/io_getline.t | 117 ++++++++++++++++++++++++++++++++++++++++
dist/IO/t/io_utf8argv.t | 13 +++--
4 files changed, 128 insertions(+), 4 deletions(-)
create mode 100644 dist/IO/t/io_getline.t
diff --git a/MANIFEST b/MANIFEST
index cb5c0bb1b4..85d3283231 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3676,6 +3676,7 @@ dist/IO/t/io_dir.t See if directory-related methods from IO work
dist/IO/t/io_dup.t See if dup()-related methods from IO work
dist/IO/t/io_file.t See if binmode()-related methods on IO::File work
dist/IO/t/io_file_export.t Test IO::File exports
+dist/IO/t/io_getline.t Test getline and getlines
dist/IO/t/io_leak.t See if IO leaks SVs (only run in core)
dist/IO/t/io_linenum.t See if I/O line numbers are tracked correctly
dist/IO/t/io_multihomed.t See if INET sockets work with multi-homed hosts
diff --git a/dist/IO/README b/dist/IO/README
index 3783750c89..5457a632c2 100644
--- a/dist/IO/README
+++ b/dist/IO/README
@@ -24,4 +24,3 @@ To build, test and install this distribution type:
Share and Enjoy!
Graham Barr <gbarr@pobox.com>
-
diff --git a/dist/IO/t/io_getline.t b/dist/IO/t/io_getline.t
new file mode 100644
index 0000000000..22361e6b7e
--- /dev/null
+++ b/dist/IO/t/io_getline.t
@@ -0,0 +1,117 @@
+#!./perl -w
+use strict;
+
+use Test::More tests => 37;
+
+my $File = 'README';
+
+use IO::File;
+
+my $io = IO::File->new($File);
+isa_ok($io, 'IO::File', "Opening $File");
+
+my $line = $io->getline();
+like($line, qr/^This is the/, "Read first line");
+
+my ($list, $context) = $io->getline();
+is($list, "\n", "Read second line");
+is($context, undef, "Did not read third line with getline() in list context");
+
+$line = $io->getline();
+like($line, qr/^This distribution/, "Read third line");
+
+my @lines = $io->getlines();
+cmp_ok(@lines, '>', 3, "getlines reads lots of lines");
+like($lines[-2], qr/^Share and Enjoy!/, "Share and Enjoy!");
+
+$line = $io->getline();
+is($line, undef, "geline reads no more at EOF");
+
+@lines = $io->getlines();
+is(@lines, 0, "gelines reads no more at EOF");
+
+# And again
+$io = IO::File->new($File);
+isa_ok($io, 'IO::File', "Opening $File");
+
+$line = $io->getline();
+like($line, qr/^This is the/, "Read first line again");
+
+is(eval {
+ $line = $io->getline("Boom");
+ 1;
+ }, undef, "eval caught an exception");
+like($@, qr/^usage.*getline\(\) at .*\bio_getline\.t line /, 'getline usage');
+like($line, qr/^This is the/, '$line unchanged');
+
+is(eval {
+ ($list, $context) = $io->getlines("Boom");
+ 1;
+ }, undef, "eval caught an exception");
+like($@, qr/^usage.*getlines\(\) at .*\bio_getline\.t line /, 'getlines usage');
+is($list, "\n", '$list unchanged');
+
+is(eval {
+ $line = $io->getlines();
+ 1;
+ }, undef, "eval caught an exception");
+like($@, qr/^Can't call .*getlines in a scalar context.* at .*\bio_getline\.t line /,
+ 'getlines in scalar context croaks');
+like($line, qr/^This is the/, '$line unchanged');
+
+is(eval {
+ $io->getlines();
+ 1;
+ }, undef, "eval caught an exception");
+like($@, qr/^Can't call .*getlines in a scalar context.* at .*\bio_getline\.t line /,
+ 'getlines in void context croaks');
+like($line, qr/^This is the/, '$line unchanged');
+
+($list, $context) = $io->getlines();
+is($list, "\n", "Read second line");
+like($context, qr/^This distribution/, "Read third line");
+
+{
+ package TiedHandle;
+
+ sub TIEHANDLE {
+ return bless ["Tick", "tick", "tick"];
+ }
+
+ sub READLINE {
+ my $fh = shift;
+ die "Boom!"
+ unless @$fh;
+ return shift @$fh
+ unless wantarray;
+ return splice @$fh;
+ }
+}
+
+tie *FH, 'TiedHandle';
+
+is(*FH->getline(), "Tick", "tied handle read works");
+($list, $context) = *FH->getline();
+is($list, "tick", "tied handle read works in list context 0");
+is($context, undef, "tied handle read works in list context 1");
+is(*FH->getline(), "tick", "tied handle read works again");
+is(eval {
+ $line = *FH->getline();
+ 1;
+ }, undef, "eval on tied handle caught an exception");
+like($@, qr/^Boom!/,
+ 'getline on tied handle propagates exception');
+like($line, qr/^This is the/, '$line unchanged');
+
+tie *FH, 'TiedHandle';
+
+($list, $context) = *FH->getlines();
+is($list, "Tick", "tied handle read works in list context 2");
+is($context, "tick", "tied handle read works in list context 3");
+is(eval {
+ ($list, $context) = *FH->getlines();
+ 1;
+ }, undef, "eval on tied handle caught an exception again");
+like($@, qr/^Boom!/,
+ 'getlines on tied handle propagates exception');
+is($list, "Tick", '$line unchanged');
diff --git a/dist/IO/t/io_utf8argv.t b/dist/IO/t/io_utf8argv.t
index 89f726a7a7..adc95d999c 100644
--- a/dist/IO/t/io_utf8argv.t
+++ b/dist/IO/t/io_utf8argv.t
@@ -13,7 +13,7 @@ use utf8;
skip_all("EBCDIC platform; testing not core")
if $::IS_EBCDIC && ! $ENV{PERL_CORE};
-plan(tests => 2);
+plan(tests => 4);
my $bytes =
"\xce\x9c\xe1\xbd\xb7\xce\xb1\x20\xcf\x80\xe1\xbd\xb1\xcf\x80\xce".
@@ -31,10 +31,17 @@ print $fh $bytes;
close $fh or die "close: $!";
-use open ":std", ":utf8";
-
use IO::Handle;
+@ARGV = ('io_utf8argv') x 2;
+is *ARGV->getline, $bytes,
+ 'getline (no open pragma) when magically opening ARGV';
+
+is join('',*ARGV->getlines), $bytes,
+ 'getlines (no open pragma) when magically opening ARGV';
+
+use open ":std", ":utf8";
+
@ARGV = ('io_utf8argv') x 2;
is *ARGV->getline, "Μία πάπια, μὰ ποιὰ πάπια;\n",
'getline respects open pragma when magically opening ARGV';
--
2.21.1

47
perl-5.31.7-Skip-the-new-open-pragma-tests-for-no-utf8-under-PER.patch Normal file
View File

@ -0,0 +1,47 @@
From 61e73f5d988b2ee25b2d90ea5570337398309e84 Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Sun, 19 Jan 2020 21:56:02 +0100
Subject: [PATCH] Skip the new open pragma tests for no ":utf8" under
PERL_UNICODE.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
PERL_UNICODE can implement an implicit use open ":utf8", which defeats the
intent of what we're testing here.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
dist/IO/t/io_utf8argv.t | 15 ++++++++++-----
1 file changed, 10 insertions(+), 5 deletions(-)
diff --git a/dist/IO/t/io_utf8argv.t b/dist/IO/t/io_utf8argv.t
index adc95d999c..b6370709f1 100644
--- a/dist/IO/t/io_utf8argv.t
+++ b/dist/IO/t/io_utf8argv.t
@@ -33,12 +33,17 @@ close $fh or die "close: $!";
use IO::Handle;
-@ARGV = ('io_utf8argv') x 2;
-is *ARGV->getline, $bytes,
- 'getline (no open pragma) when magically opening ARGV';
+SKIP: {
+ skip("PERL_UNICODE set", 2)
+ if exists $ENV{PERL_UNICODE};
+
+ @ARGV = ('io_utf8argv') x 2;
+ is *ARGV->getline, $bytes,
+ 'getline (no open pragma) when magically opening ARGV';
-is join('',*ARGV->getlines), $bytes,
- 'getlines (no open pragma) when magically opening ARGV';
+ is join('',*ARGV->getlines), $bytes,
+ 'getlines (no open pragma) when magically opening ARGV';
+}
use open ":std", ":utf8";
--
2.21.1

12
perl.spec
View File

@ -306,6 +306,11 @@ Patch73: perl-5.31.7-POSIX.pod-Update-setlocale-docs.patch
# Prevent from an integer overflow in POSIX::SigSet(), in upstream after 5.31.7
Patch74: perl-5.31.7-error-check-the-calls-to-sigaddset-in-POSIX-SigSet-n.patch
# Fix thread-safety of IO::Handle, GH#14816, in upstream after 5.31.7
Patch75: perl-5.31.7-Add-tests-for-IO-Handle-getline-and-getlines.patch
Patch76: perl-5.30.2-Loading-IO-is-now-threadsafe-avoiding-the-core-bug-r.patch
Patch77: perl-5.31.7-Skip-the-new-open-pragma-tests-for-no-utf8-under-PER.patch
# Link XS modules to libperl.so with EU::CBuilder on Linux, bug #960048
Patch200: perl-5.16.3-Link-XS-modules-to-libperl.so-with-EU-CBuilder-on-Li.patch
@ -4366,6 +4371,9 @@ you're not running VMS, this module does nothing.
%patch72 -p1
%patch73 -p1
%patch74 -p1
%patch75 -p1
%patch76 -p1
%patch77 -p1
%patch200 -p1
%patch201 -p1
@ -4433,6 +4441,9 @@ perl -x patchlevel.h \
'Fedora Patch72: Work around a glibc bug in caching LC_MESSAGES (GH#17081)' \
'Fedora Patch73: Fix POSIX:setlocale() documentation' \
'Fedora Patch74: Prevent from an integer overflow in POSIX::SigSet()' \
'Fedora Patch75: Fix thread-safety of IO::Handle (GH#14816)' \
'Fedora Patch76: Fix thread-safety of IO::Handle (GH#14816)' \
'Fedora Patch77: Fix thread-safety of IO::Handle (GH#14816)' \
'Fedora Patch200: Link XS modules to libperl.so with EU::CBuilder on Linux' \
'Fedora Patch201: Link XS modules to libperl.so with EU::MM on Linux' \
%{nil}
@ -7195,6 +7206,7 @@ popd
- Work around a glibc bug in caching LC_MESSAGES (GH#17081)
- Fix POSIX:setlocale() documentation
- Prevent from an integer overflow in POSIX::SigSet()
- Fix thread-safety of IO::Handle (GH#14816)
* Mon Mar 16 2020 Jitka Plesnikova <jplesnik@redhat.com> - 4:5.30.2-452
- 5.30.2 bump (see <https://metacpan.org/pod/release/SHAY/perl-5.30.2/pod/perldelta.pod>