PerlIO-via-0.17_01

Author: rurban

dist/Module-CoreList/lib/Module/CoreList.pm

@@ -17558,6 +17558,7 @@ our %delta = (
             'NEXT'                  => '0.67_01',
             'PerlIO::encoding'      => '0.26_01',
             'PerlIO::scalar'        => '0.29',
+            'PerlIO::via'           => '0.17_01',
             'List::Util'            => '1.50_11',
             'List::Util::XS'        => '1.50_11',
             'Scalar::Util'          => '1.50_11',

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;
@@ -44,15 +44,15 @@ is($a, $b, 'compare original data with filtered version');
     use warnings 'layer';
 
     # Find fd number we should be using
-    my $fd = open($fh,">$tmp") && fileno($fh);
+    my $fd = open($fh,'>',$tmp) && fileno($fh);
     print $fh "Hello\n";
     close($fh);
 
     ok( ! open($fh,">via(Unknown::Module)", $tmp), 'open via Unknown::Module will fail');
     like( $warnings, qr/^Cannot find package 'Unknown::Module'/,  'warn about unknown package' );
 
     # Now open normally again to see if we get right fileno
-    my $fd2 = open($fh,"<$tmp") && fileno($fh);
+    my $fd2 = open($fh,'<',$tmp) && fileno($fh);
     is($fd2,$fd,"Wrong fd number after failed open");
 
     my $data = <$fh>;
@@ -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;
 }

ext/PerlIO-via/via.pm

@@ -1,5 +1,7 @@
 package PerlIO::via;
-our $VERSION = '0.16';
+our $VERSION = '0.17_01';
+our $XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
 require XSLoader;
 XSLoader::load();
 1;

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 *
@@ -97,10 +99,8 @@ PerlIOVia_method(pTHX_ PerlIO * f, const char *method, CV ** save, int flags,
 		GvIOp(gv) = newIO();
 		s->fh = newRV((SV *) gv);
 		s->io = GvIOp(gv);
-		if (gv) {
-		    /* shamelessly stolen from IO::File's new_tmpfile() */
-		    (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
-		}
+                /* shamelessly stolen from IO::File's new_tmpfile() */
+                (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
 	    }
 	    IoIFP(s->io) = PerlIONext(f);
 	    IoOFP(s->io) = PerlIONext(f);
@@ -131,8 +131,14 @@ PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
 		 PerlIO_funcs * tab)
 {
     IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
+
+    if (arg && 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 +589,59 @@ 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
-	 */
+#ifdef USE_ITHREADS
+        if (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 */
+        }
+#endif
+        /* for a non-threaded dup fs->obj and stash should be set by _pushed() */
     }
+
     return f;
 }
 

pod/perlcdelta.pod

@@ -438,6 +438,10 @@ check invariant at compile time.
 
 return EACCES on writing to a read-only scalar
 
+=item L<PerlIO::via> 0.17_01
+
+Protect from NULL arg.
+
 =item Scalar-List-Util 1.50_11
 
 fix C<find_rundefsvoffset> logic.