This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
properly check readpipe()'s argument list
authorZefram <zefram@fysh.org>
Tue, 12 Dec 2017 06:24:01 +0000 (06:24 +0000)
committerZefram <zefram@fysh.org>
Tue, 12 Dec 2017 06:24:01 +0000 (06:24 +0000)
readpipe() wasn't applying context to its argument list, resulting in
readpipe()'s context leaking in, and broken stack discipline when a list
expression was used.  Fixes [perl #4574].

op.c
t/op/exec.t

diff --git a/op.c b/op.c
index 1d31928..74de752 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10907,6 +10907,7 @@ Perl_ck_backtick(pTHX_ OP *o)
     OP *newop = NULL;
     OP *sibl;
     PERL_ARGS_ASSERT_CK_BACKTICK;
+    o = ck_fun(o);
     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
      && (gv = gv_override("readpipe",8)))
index 5a0f7b5..b55cbda 100644 (file)
@@ -36,7 +36,7 @@ $ENV{LANGUAGE} = 'C';         # Ditto in GNU.
 my $Is_VMS   = $^O eq 'VMS';
 my $Is_Win32 = $^O eq 'MSWin32';
 
-plan(tests => 29);
+plan(tests => 38);
 
 my $Perl = which_perl();
 
@@ -128,8 +128,29 @@ is( <<~`END`,                   "ok\n",     '<<~`HEREDOC`' );
   END
 
 {
-    local $_ = qq($Perl -le "print 'ok'");
-    is( readpipe, "ok\n", 'readpipe default argument' );
+    sub rpecho { qq($Perl -le "print '$_[0]'") }
+    is scalar(readpipe(rpecho("b"))), "b\n",
+       "readpipe with one argument in scalar context";
+    is join(",", "a", readpipe(rpecho("b")), "c"), "a,b\n,c",
+       "readpipe with one argument in list context";
+    local $_ = rpecho("f");
+    is scalar(readpipe), "f\n",
+       "readpipe default argument in scalar context";
+    is join(",", "a", readpipe, "c"), "a,f\n,c",
+       "readpipe default argument in list context";
+    sub rpechocxt {
+       rpecho(wantarray ? "list" : defined(wantarray) ? "scalar" : "void");
+    }
+    is scalar(readpipe(rpechocxt())), "scalar\n",
+       "readpipe argument context in scalar context";
+    is join(",", "a", readpipe(rpechocxt()), "b"), "a,scalar\n,b",
+       "readpipe argument context in list context";
+    foreach my $args ("(\$::p,\$::q)", "((\$::p,\$::q))") {
+       foreach my $lvalue ("my \$r", "my \@r") {
+           eval("$lvalue = readpipe$args if 0");
+           like $@, qr/\AToo many arguments for /;
+       }
+    }
 }
 
 package o {