You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
300 lines
7.9 KiB
300 lines
7.9 KiB
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
|
|
|