In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/99b847695211f825df6299aa9da91f9494f741e2?hp=5d09ee1cb7b68f5e6fd15233bfe5048612e8f949>
- Log ----------------------------------------------------------------- commit 99b847695211f825df6299aa9da91f9494f741e2 Author: Tony Cook <[email protected]> Date: Thu Jun 1 15:11:27 2017 +1000 [perl #131221] improve duplication of :via handles 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. ----------------------------------------------------------------------- Summary of changes: 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 8c4950e1b4..d39f992561 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 0000000000..e4358f9c24 --- /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 6787e11cc4..80577df140 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 e477dcca19..30083feae8 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 8a7f1fc9ed..61953c8f8b 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; } -- Perl5 Master Repository
