Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Cannot clone handle with 'via' layer #15967

Closed
p5pRT opened this issue Apr 28, 2017 · 8 comments
Closed

Cannot clone handle with 'via' layer #15967

p5pRT opened this issue Apr 28, 2017 · 8 comments

Comments

@p5pRT
Copy link

p5pRT commented Apr 28, 2017

Migrated from rt.perl.org#131221 (status was 'resolved')

Searchable as RT131221$

@p5pRT
Copy link
Author

p5pRT commented Apr 28, 2017

From @exodist

Created by @exodist

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.

Perl Info

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

@p5pRT
Copy link
Author

p5pRT commented Jun 1, 2017

From @tonycoz

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.

Tony

@p5pRT
Copy link
Author

p5pRT commented Jun 1, 2017

From @tonycoz

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

@p5pRT
Copy link
Author

p5pRT commented Jun 1, 2017

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Jun 7, 2017

From @tonycoz

On Wed, 31 May 2017 22​:17​:03 -0700, tonyc wrote​:

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, '&gt;&amp;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 99b8476.

Tony

@p5pRT
Copy link
Author

p5pRT commented Jun 7, 2017

@tonycoz - Status changed from 'open' to 'pending release'

@p5pRT
Copy link
Author

p5pRT commented Jun 23, 2018

From @khwilliamson

Thank you for filing this report. You have helped make Perl better.

With the release yesterday of Perl 5.28.0, this and 185 other issues have been
resolved.

Perl 5.28.0 may be downloaded via​:
https://metacpan.org/release/XSAWYERX/perl-5.28.0

If you find that the problem persists, feel free to reopen this ticket.

@p5pRT p5pRT closed this as completed Jun 23, 2018
@p5pRT
Copy link
Author

p5pRT commented Jun 23, 2018

@khwilliamson - Status changed from 'pending release' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Development

No branches or pull requests

1 participant