Cannot clone handle with 'via' layer

[p5pRT]

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

Searchable as RT131221$

[p5pRT]

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]

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]

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]

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

[p5pRT]

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, '>&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]

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

[p5pRT]

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]

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