Re: [perl #123775] Args to 'system' not evaluated before forking,making $$ wrong

Front page | perl.perl5.porters | Postings from February 2015

Re: [perl #123775] Args to 'system' not evaluated before forking,making $$ wrong

Thread Previous | Thread Next

From:

Leon Timmermans

Date:

February 14, 2015 00:46

Subject:

Re: [perl #123775] Args to 'system' not evaluated before forking,making $$ wrong

Message ID:

CAHhgV8j+wbiV6WULvFCv_u7ij_yUH_=TDFGpcU12kiCQP7Tvkg@mail.gmail.com

From 14e44794d6597318abed388a8614f5f28eb91389 Mon Sep 17 00:00:00 2001
From: Leon Timmermans <fawaka@gmail.com>
Date: Sat, 14 Feb 2015 00:37:18 +0100
Subject: [PATCH] Evaluate get magic in system and openpipe before the fork

---
 doio.c      |  2 +-
 mathoms.c   |  4 ++++
 pp_sys.c    |  6 ++++++
 t/op/exec.t | 20 +++++++++++++++++++-
 util.c      |  7 +++++++
 5 files changed, 37 insertions(+), 2 deletions(-)

diff --git a/doio.c b/doio.c
index a63f2a2..dc4de86 100644
--- a/doio.c
+++ b/doio.c
@@ -1544,7 +1544,7 @@ Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
 
 	while (++mark <= sp) {
 	    if (*mark)
-		*a++ = SvPV_nolen_const(*mark);
+        *a++ = SvPV_nomg_nolen(*mark);
 	    else
 		*a++ = "";
 	}
diff --git a/mathoms.c b/mathoms.c
index 2a65fb4..6ad8eb3 100644
--- a/mathoms.c
+++ b/mathoms.c
@@ -713,8 +713,12 @@ Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
 bool
 Perl_do_aexec(pTHX_ SV *really, SV **mark, SV **sp)
 {
+    SV** current;
     PERL_ARGS_ASSERT_DO_AEXEC;
 
+    for (current = mark + 1; current <= SP; current++) {
+        SvGETMAGIC(*current);
+    }
     return do_aexec5(really, mark, sp, 0, 0);
 }
 #endif
diff --git a/pp_sys.c b/pp_sys.c
index e2f8edf..7e4ff61 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -4259,6 +4259,12 @@ PP(pp_system)
 	MARK = ORIGMARK;
 	TAINT_PROPER("system");
     }
+    else {
+        while (++MARK <= SP) {
+            (void)SvGETMAGIC(*MARK);      /* For get magic */
+        }
+        MARK = ORIGMARK;
+    }
     PERL_FLUSHALL_FOR_CHILD;
 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
     {
diff --git a/t/op/exec.t b/t/op/exec.t
index 6ec3646..e7ef923 100644
--- a/t/op/exec.t
+++ b/t/op/exec.t
@@ -36,7 +36,7 @@ $ENV{LANGUAGE} = 'C';		# Ditto in GNU.
 my $Is_VMS   = $^O eq 'VMS';
 my $Is_Win32 = $^O eq 'MSWin32';
 
-plan(tests => 24);
+plan(tests => 26);
 
 my $Perl = which_perl();
 
@@ -153,6 +153,24 @@ TODO: {
         "exec failure doesn't terminate process");
 }
 
+SKIP: {
+    skip 'Doesn\'t work on Windows/VMS', 2 if $Is_VMS || $Is_Win32;
+    open my $fh, '-|', 'echo', $$;
+    my $pid = <$fh>;
+    chomp $pid;
+    is($pid, $$, 'Pid is as expected in openpipe');
+
+    skip 'Can\'t load POSIX' if not eval { require POSIX };
+    if (my $child = open my $fh, '-|') {
+        my $pid = <$fh>;
+        chomp $pid;
+        is($pid, $child, 'Pid is as expected in system');
+    } else {
+        system 'echo', $$;
+        POSIX::_exit(0);
+    }
+}
+
 my $test = curr_test();
 exec $Perl, '-le', qq{${quote}print 'ok $test - exec PROG, LIST'${quote}};
 fail("This should never be reached if the exec() worked");
diff --git a/util.c b/util.c
index 9ffdbde..ebd3ab4 100644
--- a/util.c
+++ b/util.c
@@ -2349,6 +2349,13 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
     /* Try for another pipe pair for error return */
     if (PerlProc_pipe(pp) >= 0)
 	did_pipes = 1;
+
+    {
+        SV** current;
+        for (current = args; current <= args-1+n; current++) {
+            SvGETMAGIC(*current);
+        }
+    }
     while ((pid = PerlProc_fork()) < 0) {
 	if (errno != EAGAIN) {
 	    PerlLIO_close(p[This]);
-- 
2.2.0-369-g3b010e3

Thread Previous | Thread Next