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

Fix cloning :via handles on thread creation

Browse Source
This commit is contained in:
Petr Písař 2017-06-16 14:46:27 +02:00
parent 1e8061ae22
commit f5f43f18f9
3 changed files with 379 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

299
perl-5.27.0-perl-131221-improve-duplication-of-via-handles.patch Normal file
View File

@ -0,0 +1,299 @@
From 99b847695211f825df6299aa9da91f9494f741e2 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 1 Jun 2017 15:11:27 +1000
Subject: [PATCH] [perl #131221] improve duplication of :via handles
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Previously duplication (as with open ... ">&...") would fail
unless the user supplied a GETARG, which wasn't documented, and
resulted in an attempt to free and unreferened scalar if supplied.
Cloning on thread creation was simply broken.
We now handle GETARG correctly, and provide a useful default if it
returns nothing.
Cloning on thread creation now duplicates the appropriate parts of the
parent thread's handle.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
MANIFEST | 1 +
ext/PerlIO-via/t/thread.t | 73 +++++++++++++++++++++++++++++++++++++++++++++++
ext/PerlIO-via/t/via.t | 56 +++++++++++++++++++++++++++++++++++-
ext/PerlIO-via/via.pm | 2 +-
ext/PerlIO-via/via.xs | 55 +++++++++++++++++++++++++++++++----
5 files changed, 179 insertions(+), 8 deletions(-)
create mode 100644 ext/PerlIO-via/t/thread.t
diff --git a/MANIFEST b/MANIFEST
index 8c4950e..d39f992 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4056,6 +4056,7 @@ ext/PerlIO-scalar/scalar.xs PerlIO layer for scalars
ext/PerlIO-scalar/t/scalar.t See if PerlIO::scalar works
ext/PerlIO-scalar/t/scalar_ungetc.t Tests for PerlIO layer for scalars
ext/PerlIO-via/hints/aix.pl Hint for PerlIO::via for named architecture
+ext/PerlIO-via/t/thread.t See if PerlIO::via works with threads
ext/PerlIO-via/t/via.t See if PerlIO::via works
ext/PerlIO-via/via.pm PerlIO layer for layers in perl
ext/PerlIO-via/via.xs PerlIO layer for layers in perl
diff --git a/ext/PerlIO-via/t/thread.t b/ext/PerlIO-via/t/thread.t
new file mode 100644
index 0000000..e4358f9
--- /dev/null
+++ b/ext/PerlIO-via/t/thread.t
@@ -0,0 +1,73 @@
+#!perl
+BEGIN {
+ unless (find PerlIO::Layer 'perlio') {
+ print "1..0 # Skip: not perlio\n";
+ exit 0;
+ }
+ require Config;
+ unless ($Config::Config{'usethreads'}) {
+ print "1..0 # Skip -- need threads for this test\n";
+ exit 0;
+ }
+ if (($Config::Config{'extensions'} !~ m!\bPerlIO/via\b!) ){
+ print "1..0 # Skip -- Perl configured without PerlIO::via module\n";
+ exit 0;
+ }
+}
+
+use strict;
+use warnings;
+use threads;
+
+my $tmp = "via$$";
+
+END {
+ 1 while unlink $tmp;
+}
+
+use Test::More tests => 2;
+
+our $push_count = 0;
+
+{
+ open my $fh, ">:via(Test1)", $tmp
+ or die "Cannot open $tmp: $!";
+ $fh->autoflush;
+
+ print $fh "AXAX";
+
+ # previously this would crash
+ threads->create(
+ sub {
+ print $fh "XZXZ";
+ })->join;
+
+ print $fh "BXBX";
+ close $fh;
+
+ open my $in, "<", $tmp;
+ my $line = <$in>;
+ close $in;
+
+ is($line, "AYAYYZYZBYBY", "check thread data delivered");
+
+ is($push_count, 1, "PUSHED not called for dup on thread creation");
+}
+
+package PerlIO::via::Test1;
+
+sub PUSHED {
+ my ($class) = @_;
+ ++$main::push_count;
+ bless {}, $class;
+}
+
+sub WRITE {
+ my ($self, $data, $fh) = @_;
+ $data =~ tr/X/Y/;
+ $fh->autoflush;
+ print $fh $data;
+ return length $data;
+}
+
+
diff --git a/ext/PerlIO-via/t/via.t b/ext/PerlIO-via/t/via.t
index 6787e11..80577df 100644
--- a/ext/PerlIO-via/t/via.t
+++ b/ext/PerlIO-via/t/via.t
@@ -17,7 +17,7 @@ use warnings;
my $tmp = "via$$";
-use Test::More tests => 18;
+use Test::More tests => 26;
my $fh;
my $a = join("", map { chr } 0..255) x 10;
@@ -84,6 +84,60 @@ is( $obj, 'Foo', 'search for package Foo' );
open $fh, '<:via(Bar)', "bar";
is( $obj, 'PerlIO::via::Bar', 'search for package PerlIO::via::Bar' );
+{
+ # [perl #131221]
+ ok(open(my $fh1, ">", $tmp), "open $tmp");
+ ok(binmode($fh1, ":via(XXX)"), "binmode :via(XXX) onto it");
+ ok(open(my $fh2, ">&", $fh1), "dup it");
+ close $fh1;
+ close $fh2;
+
+ # make sure the old workaround still works
+ ok(open($fh1, ">", $tmp), "open $tmp");
+ ok(binmode($fh1, ":via(YYY)"), "binmode :via(YYY) onto it");
+ ok(open($fh2, ">&", $fh1), "dup it");
+ print $fh2 "XZXZ";
+ close $fh1;
+ close $fh2;
+
+ ok(open($fh1, "<", $tmp), "open $tmp for check");
+ { local $/; $b = <$fh1> }
+ close $fh1;
+ is($b, "XZXZ", "check result is from non-filtering class");
+
+ package PerlIO::via::XXX;
+
+ sub PUSHED {
+ my $class = shift;
+ bless {}, $class;
+ }
+
+ sub WRITE {
+ my ($self, $buffer, $handle) = @_;
+
+ print $handle $buffer;
+ return length($buffer);
+ }
+ package PerlIO::via::YYY;
+
+ sub PUSHED {
+ my $class = shift;
+ bless {}, $class;
+ }
+
+ sub WRITE {
+ my ($self, $buffer, $handle) = @_;
+
+ $buffer =~ tr/X/Y/;
+ print $handle $buffer;
+ return length($buffer);
+ }
+
+ sub GETARG {
+ "XXX";
+ }
+}
+
END {
1 while unlink $tmp;
}
diff --git a/ext/PerlIO-via/via.pm b/ext/PerlIO-via/via.pm
index e477dcc..30083fe 100644
--- a/ext/PerlIO-via/via.pm
+++ b/ext/PerlIO-via/via.pm
@@ -1,5 +1,5 @@
package PerlIO::via;
-our $VERSION = '0.16';
+our $VERSION = '0.17';
require XSLoader;
XSLoader::load();
1;
diff --git a/ext/PerlIO-via/via.xs b/ext/PerlIO-via/via.xs
index 8a7f1fc..61953c8 100644
--- a/ext/PerlIO-via/via.xs
+++ b/ext/PerlIO-via/via.xs
@@ -38,6 +38,8 @@ typedef struct
CV *UTF8;
} PerlIOVia;
+static const MGVTBL PerlIOVia_tag = { 0, 0, 0, 0, 0, 0, 0, 0 };
+
#define MYMethod(x) #x,&s->x
static CV *
@@ -131,8 +133,14 @@ PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
PerlIO_funcs * tab)
{
IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
+
+ if (SvTYPE(arg) >= SVt_PVMG
+ && mg_findext(arg, PERL_MAGIC_ext, &PerlIOVia_tag)) {
+ return code;
+ }
+
if (code == 0) {
- PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
+ PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
if (!arg) {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER),
@@ -583,20 +591,55 @@ static SV *
PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
{
PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
- PERL_UNUSED_ARG(param);
+ SV *arg;
PERL_UNUSED_ARG(flags);
- return PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv);
+
+ /* During cloning, return an undef token object so that _pushed() knows
+ * that it should not call methods and wait for _dup() to actually dup the
+ * object. */
+ if (param) {
+ SV *sv = newSV(0);
+ sv_magicext(sv, NULL, PERL_MAGIC_ext, &PerlIOVia_tag, 0, 0);
+ return sv;
+ }
+
+ arg = PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv);
+ if (arg) {
+ /* arg is a temp, and PerlIOBase_dup() will explicitly free it */
+ SvREFCNT_inc(arg);
+ }
+ else {
+ arg = newSVpvn(HvNAME(s->stash), HvNAMELEN(s->stash));
+ }
+
+ return arg;
}
static PerlIO *
PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
int flags)
{
- if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
- /* Most of the fields will lazily set themselves up as needed
- stash and obj have been set up by the implied push
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)) && param) {
+ /* For a non-interpreter dup stash and obj have been set up
+ by the implied push.
+
+ But if this is a clone for a new interpreter we need to
+ translate the objects to their dups.
*/
+
+ PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
+ PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
+
+ fs->obj = sv_dup_inc(os->obj, param);
+ fs->stash = (HV*)sv_dup((SV*)os->stash, param);
+ fs->var = sv_dup_inc(os->var, param);
+ fs->cnt = os->cnt;
+
+ /* fh, io, cached CVs left as NULL, PerlIOVia_method()
+ will reinitialize them if needed */
}
+ /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
+
return f;
}
--
2.9.4

71
perl-5.27.0-perl-131221-sv_dup-sv_dup_inc-are-only-available-und.patch Normal file
View File

@ -0,0 +1,71 @@
From 7b3443d31f11c15859593e5b710c301795a6de01 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 8 Jun 2017 11:06:39 +1000
Subject: [PATCH] [perl #131221] sv_dup/sv_dup_inc are only available under
threads
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
ext/PerlIO-via/via.xs | 42 +++++++++++++++++++++++-------------------
1 file changed, 23 insertions(+), 19 deletions(-)
diff --git a/ext/PerlIO-via/via.xs b/ext/PerlIO-via/via.xs
index 61953c8..d91c685 100644
--- a/ext/PerlIO-via/via.xs
+++ b/ext/PerlIO-via/via.xs
@@ -619,26 +619,30 @@ static PerlIO *
PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
int flags)
{
- if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)) && param) {
- /* For a non-interpreter dup stash and obj have been set up
- by the implied push.
-
- But if this is a clone for a new interpreter we need to
- translate the objects to their dups.
- */
-
- PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
- PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
-
- fs->obj = sv_dup_inc(os->obj, param);
- fs->stash = (HV*)sv_dup((SV*)os->stash, param);
- fs->var = sv_dup_inc(os->var, param);
- fs->cnt = os->cnt;
-
- /* fh, io, cached CVs left as NULL, PerlIOVia_method()
- will reinitialize them if needed */
+ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
+#ifdef USE_ITHREADS
+ if (param) {
+ /* For a non-interpreter dup stash and obj have been set up
+ by the implied push.
+
+ But if this is a clone for a new interpreter we need to
+ translate the objects to their dups.
+ */
+
+ PerlIOVia *fs = PerlIOSelf(f, PerlIOVia);
+ PerlIOVia *os = PerlIOSelf(o, PerlIOVia);
+
+ fs->obj = sv_dup_inc(os->obj, param);
+ fs->stash = (HV*)sv_dup((SV*)os->stash, param);
+ fs->var = sv_dup_inc(os->var, param);
+ fs->cnt = os->cnt;
+
+ /* fh, io, cached CVs left as NULL, PerlIOVia_method()
+ will reinitialize them if needed */
+ }
+#endif
+ /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
}
- /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
return f;
}
--
2.9.4

9
perl.spec
View File

@ -149,6 +149,11 @@ Patch32: perl-5.27.0-perl-131085-Crash-with-sub-in-stash.patch
# RT#131190, in upstream after 5.27.0 # RT#131190, in upstream after 5.27.0
Patch33: perl-5.27.0-Fix-131190-UTF8-code-improperly-casting-negative-int.patch Patch33: perl-5.27.0-Fix-131190-UTF8-code-improperly-casting-negative-int.patch
# Fix cloning :via handles on thread creation, RT#131221,
# in upstream after 5.27.0
Patch34: perl-5.27.0-perl-131221-improve-duplication-of-via-handles.patch
Patch35: perl-5.27.0-perl-131221-sv_dup-sv_dup_inc-are-only-available-und.patch
# Link XS modules to libperl.so with EU::CBuilder on Linux, bug #960048 # 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 Patch200: perl-5.16.3-Link-XS-modules-to-libperl.so-with-EU-CBuilder-on-Li.patch
@ -2800,6 +2805,8 @@ Perl extension for Version Objects
%patch31 -p1 %patch31 -p1
%patch32 -p1 %patch32 -p1
%patch33 -p1 %patch33 -p1
%patch34 -p1
%patch35 -p1
%patch200 -p1 %patch200 -p1
%patch201 -p1 %patch201 -p1
@ -2823,6 +2830,7 @@ perl -x patchlevel.h \
'Fedora Patch31: Make File::Glob more resistant against degenerative matching (RT#131211)' \ 'Fedora Patch31: Make File::Glob more resistant against degenerative matching (RT#131211)' \
'Fedora Patch32: Fix a crash when calling a subroutine from a stash (RT#131085)' \ 'Fedora Patch32: Fix a crash when calling a subroutine from a stash (RT#131085)' \
'Fedora Patch33: Fix an improper cast of a negative integer to an unsigned 8-bit type (RT#131190)' \ 'Fedora Patch33: Fix an improper cast of a negative integer to an unsigned 8-bit type (RT#131190)' \
'Fedora Patch34: Fix cloning :via handles on thread creation (RT#131221)' \
'Fedora Patch200: Link XS modules to libperl.so with EU::CBuilder on Linux' \ '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' \ 'Fedora Patch201: Link XS modules to libperl.so with EU::MM on Linux' \
%{nil} %{nil}
@ -5109,6 +5117,7 @@ popd
- Make File::Glob more resistant against degenerative matching (RT#131211) - Make File::Glob more resistant against degenerative matching (RT#131211)
- Fix a crash when calling a subroutine from a stash (RT#131085) - Fix a crash when calling a subroutine from a stash (RT#131085)
- Fix an improper cast of a negative integer to an unsigned 8-bit type (RT#131190) - Fix an improper cast of a negative integer to an unsigned 8-bit type (RT#131190)
- Fix cloning :via handles on thread creation (RT#131221)
* Tue Jun 06 2017 Jitka Plesnikova <jplesnik@redhat.com> - 4:5.26.0-393 * Tue Jun 06 2017 Jitka Plesnikova <jplesnik@redhat.com> - 4:5.26.0-393
- Stop providing old perl(MODULE_COMPAT_5.24.*) - Stop providing old perl(MODULE_COMPAT_5.24.*)