Skip Menu |
Report information
Id: 131221
Status: pending release
Priority: 0/
Queue: perl5

Owner: Nobody
Requestors: exodist7 [at] gmail.com
Cc:
AdminCc:

Operating System: Linux
PatchStatus: (no value)
Severity: medium
Type: core
Perl Version: 5.24.1
Fixed In: (no value)

Attachments
0001-perl-131221-improve-duplication-of-via-handles.patch



To: perlbug [...] perl.org
Subject: Cannot clone handle with 'via' layer
From: Chad Granum <exodist7 [...] gmail.com>
Date: Thu, 27 Apr 2017 21:11:08 -0700
Download (untitled) / with headers
text/plain 4.2k
This is a bug report for perl from exodist7@gmail.com,
generated with the help of perlbug 1.40 running under perl 5.24.1.


-----------------------------------------------------------------
[Please describe your issue here]

You cannot clone a filehandle that has a 'via' perlio layer applied to it. 

Example script:

    use strict;
    use warnings;

    binmode(STDOUT, ':via(XXX)');
    open(my $fh, '>&STDOUT') or die "Could not clone STDOUT: $!";

    package PerlIO::via::XXX;

    sub PUSHED {
        my $class = shift;
        bless {}, $class;
    }   

    sub WRITE {
        my ($self, $buffer, $handle) = @_; 

        print $handle $buffer;
        return length($buffer);
    }   

Output:

    No package specified at test.pl line 5.
    Could not clone STDOUT: Invalid argument at test.pl line 5.



From what I can tell when poking around it looks like it is trying to apply all 
the same layers to the new handle, but when it gets to via it passes it as
':via' without the (XXX) argument.



[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
    category=core
    severity=medium
---
Site configuration information for perl 5.24.1:

Configured by exodist at Fri Mar 31 18:01:00 PDT 2017.

Summary of my perl5 (revision 5 version 24 subversion 1) configuration:
___
  Platform:
    osname=linux, osvers=4.10.6-1-arch, archname=x86_64-linux-thread-multi
    uname='linux abydos 4.10.6-1-arch #1 smp preempt mon mar 27 08:28:22 cest 2017 x86_64 gnulinux '
    config_args='-de -Dprefix=/home/exodist/perl5/perlbrew/perls/main -Dusethreads -Aeval:scriptdir=/home/exodist/perl5/perlbrew/perls/main/bin'
    hint=recommended, useposix=true, d_sigaction=define
    useithreads=define, usemultiplicity=define
    use64bitint=define, use64bitall=define, uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
    optimize='-O2',
    cppflags='-D_REENTRANT -D_GNU_SOURCE -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/usr/local/include'
    ccversion='', gccversion='6.3.1 20170306', gccosandvers=''
    intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678, doublekind=3
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16, longdblkind=3
    ivtype='long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
    alignbytes=8, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -fstack-protector-strong -L/usr/local/lib'
    libpth=/usr/local/lib /usr/lib/gcc/x86_64-pc-linux-gnu/6.3.1/include-fixed /usr/lib /lib/../lib /usr/lib/../lib /lib /lib64 /usr/lib64
    libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat
    perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc
    libc=libc-2.25.so, so=so, useshrplib=false, libperl=libperl.a
    gnulibc_version='2.25'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
    cccdlflags='-fPIC', lddlflags='-shared -O2 -L/usr/local/lib -fstack-protector-strong'

Locally applied patches:
    Devel::PatchPerl 1.46

---
@INC for perl 5.24.1:
    /home/exodist/perl5/perlbrew/perls/main/lib/site_perl/5.24.1/x86_64-linux-thread-multi
    /home/exodist/perl5/perlbrew/perls/main/lib/site_perl/5.24.1
    /home/exodist/perl5/perlbrew/perls/main/lib/5.24.1/x86_64-linux-thread-multi
    /home/exodist/perl5/perlbrew/perls/main/lib/5.24.1

---
Environment for perl 5.24.1:
    HOME=/home/exodist
    LANG=en_US.UTF-8
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/home/exodist/perl5/perlbrew/bin:/home/exodist/perl5/perlbrew/perls/main/bin:/home/exodist/bin:/usr/local/sbin:/usr/local/bin:/usr/bin:/usr/bin/site_perl:/usr/bin/vendor_perl:/usr/bin/core_perl
    PERLBREW_BASHRC_VERSION=0.78
    PERLBREW_HOME=/home/exodist/.perlbrew
    PERLBREW_MANPATH=/home/exodist/perl5/perlbrew/perls/main/man
    PERLBREW_PATH=/home/exodist/perl5/perlbrew/bin:/home/exodist/perl5/perlbrew/perls/main/bin
    PERLBREW_PERL=main
    PERLBREW_ROOT=/home/exodist/perl5/perlbrew
    PERLBREW_VERSION=0.78
    PERL_BADLANG (unset)
    SHELL=/usr/bin/zsh

RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 961b
On Thu, 27 Apr 2017 21:11:20 -0700, exodist7@gmail.com wrote: Show quoted text
> You cannot clone a filehandle that has a 'via' perlio layer applied to > it. > > Example script: > > use strict; > use warnings; > > binmode(STDOUT, ':via(XXX)'); > open(my $fh, '>&STDOUT') or die "Could not clone STDOUT: $!"; > > package PerlIO::via::XXX; > > sub PUSHED { > my $class = shift; > bless {}, $class; > } > > sub WRITE { > my ($self, $buffer, $handle) = @_; > > print $handle $buffer; > return length($buffer); > } > > Output: > > No package specified at test.pl line 5. > Could not clone STDOUT: Invalid argument at test.pl line 5. > > > > From what I can tell when poking around it looks like it is trying to > apply > all > the same layers to the new handle, but when it gets to via it passes > it as > ':via' without the (XXX) argument.
It's sort of possible to fix this by applying a GETARG method, but that's broken too. Please try the attached. Tony
Subject: 0001-perl-131221-improve-duplication-of-via-handles.patch
From 76e8b4aed1660ab272c138f0e954171ae33206ca Mon Sep 17 00:00:00 2001 From: Tony Cook <tony@develop-help.com> Date: Thu, 1 Jun 2017 15:11:27 +1000 Subject: [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. --- 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 b7b6e74..521895e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4045,6 +4045,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.1.4
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 1.1k
On Wed, 31 May 2017 22:17:03 -0700, tonyc wrote: Show quoted text
> On Thu, 27 Apr 2017 21:11:20 -0700, exodist7@gmail.com wrote:
> > You cannot clone a filehandle that has a 'via' perlio layer applied > > to > > it. > > > > Example script: > > > > use strict; > > use warnings; > > > > binmode(STDOUT, ':via(XXX)'); > > open(my $fh, '>&STDOUT') or die "Could not clone STDOUT: $!"; > > > > package PerlIO::via::XXX; > > > > sub PUSHED { > > my $class = shift; > > bless {}, $class; > > } > > > > sub WRITE { > > my ($self, $buffer, $handle) = @_; > > > > print $handle $buffer; > > return length($buffer); > > } > > > > Output: > > > > No package specified at test.pl line 5. > > Could not clone STDOUT: Invalid argument at test.pl line 5. > > > > > > > > From what I can tell when poking around it looks like it is trying to > > apply > > all > > the same layers to the new handle, but when it gets to via it passes > > it as > > ':via' without the (XXX) argument.
> > It's sort of possible to fix this by applying a GETARG method, but > that's broken too. > > Please try the attached.
Applied as 99b847695211f825df6299aa9da91f9494f741e2. Tony


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

For issues related to this RT instance (aka "perlbug"), please contact perlbug-admin at perl.org