From 0921ffc8e9ce2ec66b11078f7de9759524746c87 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppi...@redhat.com>
Date: Fri, 16 Jun 2017 14:46:27 +0200
Subject: Fix cloning :via handles on thread creation
---
...131221-improve-duplication-of-via-handles.patch | 299 +++++++++++++++++++++
...-sv_dup-sv_dup_inc-are-only-available-und.patch | 71 +++++
perl.spec | 9 +
3 files changed, 379 insertions(+)
create mode 100644
perl-5.27.0-perl-131221-improve-duplication-of-via-handles.patch
create mode 100644
perl-5.27.0-perl-131221-sv_dup-sv_dup_inc-are-only-available-und.patch
diff --git a/perl-5.27.0-perl-131221-improve-duplication-of-via-handles.patch
b/perl-5.27.0-perl-131221-improve-duplication-of-via-handles.patch
new file mode 100644
index 0000000..37da371
--- /dev/null
+++ b/perl-5.27.0-perl-131221-improve-duplication-of-via-handles.patch
@@ -0,0 +1,299 @@
+From 99b847695211f825df6299aa9da91f9494f741e2 Mon Sep 17 00:00:00 2001
+From: Tony Cook <t...@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ř <ppi...@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
+
diff --git
a/perl-5.27.0-perl-131221-sv_dup-sv_dup_inc-are-only-available-und.patch
b/perl-5.27.0-perl-131221-sv_dup-sv_dup_inc-are-only-available-und.patch
new file mode 100644
index 0000000..f0e89da
--- /dev/null
+++ b/perl-5.27.0-perl-131221-sv_dup-sv_dup_inc-are-only-available-und.patch
@@ -0,0 +1,71 @@
+From 7b3443d31f11c15859593e5b710c301795a6de01 Mon Sep 17 00:00:00 2001
+From: Tony Cook <t...@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ř <ppi...@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
+
diff --git a/perl.spec b/perl.spec
index bd8a6fc..f561d40 100644
--- a/perl.spec
+++ b/perl.spec
@@ -339,6 +339,11 @@ Patch96:
perl-5.24.1-perl-131085-Crash-with-sub-in-stash.patch
# RT#131190, in upstream after 5.27.0
Patch97:
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
+Patch98:
perl-5.27.0-perl-131221-improve-duplication-of-via-handles.patch
+Patch99:
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
Patch200:
perl-5.16.3-Link-XS-modules-to-libperl.so-with-EU-CBuilder-on-Li.patch
@@ -3059,6 +3064,8 @@ Perl extension for Version Objects
%patch95 -p1
%patch96 -p1
%patch97 -p1
+%patch98 -p1
+%patch99 -p1
%patch200 -p1
%patch201 -p1
@@ -3137,6 +3144,7 @@ perl -x patchlevel.h \
'Fedora Patch94: Fix a memory wrap in sv_vcatpvfn_flags() (RT#131260)' \
'Fedora Patch96: Fix a crash when calling a subroutine from a stash
(RT#131085)' \
'Fedora Patch97: Fix an improper cast of a negative integer to an unsigned
8-bit type (RT#131190)' \
+ 'Fedora Patch98: Fix cloning :via handles on thread creation (RT#131221)' \
'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}
@@ -5420,6 +5428,7 @@ popd
- Fix a memory wrap in sv_vcatpvfn_flags() (RT#131260)
- 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 cloning :via handles on thread creation (RT#131221)
* Wed Mar 08 2017 Petr Pisar <ppi...@redhat.com> - 4:5.24.1-385
- Fix a null-pointer dereference on malformed code (RT#130815)
--
cgit v1.1
https://src.fedoraproject.org/cgit/perl.git/commit/?h=f25&id=0921ffc8e9ce2ec66b11078f7de9759524746c87
_______________________________________________
perl-devel mailing list -- perl-devel@lists.fedoraproject.org
To unsubscribe send an email to perl-devel-le...@lists.fedoraproject.org
