import perl 5.16.3 from CPAN - worked on by Andrew Fresh and myself

4 files changed, 321 insertions, 59 deletions

diff --git a/gnu/usr.bin/perl/ext/IPC-Open3/lib/IPC/Open2.pm b/gnu/usr.bin/perl/ext/IPC-Open3/lib/IPC/Open2.pm
new file mode 100644
index 00000000000..9e27144571d
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IPC-Open3/lib/IPC/Open2.pm
@@ -0,0 +1,120 @@
+package IPC::Open2;
+
+use strict;
+our ($VERSION, @ISA, @EXPORT);
+
+require 5.000;
+require Exporter;
+
+$VERSION	= 1.04;
+@ISA		= qw(Exporter);
+@EXPORT		= qw(open2);
+
+=head1 NAME
+
+IPC::Open2 - open a process for both reading and writing using open2()
+
+=head1 SYNOPSIS
+
+    use IPC::Open2;
+
+    $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'some cmd and args');
+      # or without using the shell
+    $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'some', 'cmd', 'and', 'args');
+
+    # or with handle autovivification
+    my($chld_out, $chld_in);
+    $pid = open2($chld_out, $chld_in, 'some cmd and args');
+      # or without using the shell
+    $pid = open2($chld_out, $chld_in, 'some', 'cmd', 'and', 'args');
+
+    waitpid( $pid, 0 );
+    my $child_exit_status = $? >> 8;
+
+=head1 DESCRIPTION
+
+The open2() function runs the given $cmd and connects $chld_out for
+reading and $chld_in for writing.  It's what you think should work 
+when you try
+
+    $pid = open(HANDLE, "|cmd args|");
+
+The write filehandle will have autoflush turned on.
+
+If $chld_out is a string (that is, a bareword filehandle rather than a glob
+or a reference) and it begins with C<< >& >>, then the child will send output
+directly to that file handle.  If $chld_in is a string that begins with
+C<< <& >>, then $chld_in will be closed in the parent, and the child will
+read from it directly.  In both cases, there will be a dup(2) instead of a
+pipe(2) made.
+
+If either reader or writer is the null string, this will be replaced
+by an autogenerated filehandle.  If so, you must pass a valid lvalue
+in the parameter slot so it can be overwritten in the caller, or
+an exception will be raised.
+
+open2() returns the process ID of the child process.  It doesn't return on
+failure: it just raises an exception matching C</^open2:/>.  However,
+C<exec> failures in the child are not detected.  You'll have to
+trap SIGPIPE yourself.
+
+open2() does not wait for and reap the child process after it exits.
+Except for short programs where it's acceptable to let the operating system
+take care of this, you need to do this yourself.  This is normally as
+simple as calling C<waitpid $pid, 0> when you're done with the process.
+Failing to do this can result in an accumulation of defunct or "zombie"
+processes.  See L<perlfunc/waitpid> for more information.
+
+This whole affair is quite dangerous, as you may block forever.  It
+assumes it's going to talk to something like B<bc>, both writing
+to it and reading from it.  This is presumably safe because you
+"know" that commands like B<bc> will read a line at a time and
+output a line at a time.  Programs like B<sort> that read their
+entire input stream first, however, are quite apt to cause deadlock.
+
+The big problem with this approach is that if you don't have control 
+over source code being run in the child process, you can't control
+what it does with pipe buffering.  Thus you can't just open a pipe to
+C<cat -v> and continually read and write a line from it.
+
+The IO::Pty and Expect modules from CPAN can help with this, as they
+provide a real tty (well, a pseudo-tty, actually), which gets you
+back to line buffering in the invoked command again.
+
+=head1 WARNING 
+
+The order of arguments differs from that of open3().
+
+=head1 SEE ALSO
+
+See L<IPC::Open3> for an alternative that handles STDERR as well.  This
+function is really just a wrapper around open3().
+
+=cut
+
+# &open2: tom christiansen, <tchrist@convex.com>
+#
+# usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
+#    or  $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
+#
+# spawn the given $cmd and connect $rdr for
+# reading and $wtr for writing.  return pid
+# of child, or 0 on failure.  
+# 
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.  
+# 
+# $wtr is left unbuffered.
+# 
+# abort program if
+#	rdr or wtr are null
+# 	a system call fails
+
+require IPC::Open3;
+
+sub open2 {
+    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+    return IPC::Open3::_open3('open2', $_[1], $_[0], '>&STDERR', @_[2 .. $#_]);
+}
+
+1
diff --git a/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open2.t b/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open2.t
new file mode 100644
index 00000000000..e0be5dbf529
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open2.t
@@ -0,0 +1,61 @@
+#!./perl -w
+
+use Config;
+BEGIN {
+    require Test::More;
+    if (!$Config{'d_fork'}
+       # open2/3 supported on win32
+       && $^O ne 'MSWin32' && $^O ne 'NetWare')
+    {
+	Test::More->import(skip_all => 'open2/3 not available with MSWin32+Netware');
+	exit 0;
+    }
+    # make warnings fatal
+    $SIG{__WARN__} = sub { die @_ };
+}
+
+use strict;
+use IPC::Open2;
+use Test::More tests => 15;
+
+my $perl = $^X;
+
+sub cmd_line {
+	if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
+		return qq/"$_[0]"/;
+	}
+	else {
+		return $_[0];
+	}
+}
+
+STDOUT->autoflush;
+STDERR->autoflush;
+
+my $pid = open2('READ', 'WRITE', $perl, '-e', cmd_line('print scalar <STDIN>'));
+cmp_ok($pid, '>', 1, 'got a sane process ID');
+ok(print WRITE "hi kid\n");
+like(<READ>, qr/^hi kid\r?\n$/);
+ok(close(WRITE), "closing WRITE: $!");
+ok(close(READ), "closing READ: $!");
+my $reaped_pid = waitpid $pid, 0;
+is($reaped_pid, $pid, "Reaped PID matches");
+is($?, 0, '$? should be zero');
+
+{
+    package SKREEEK;
+    my $pid = IPC::Open2::open2('KAZOP', 'WRITE', $perl, '-e',
+				main::cmd_line('print scalar <STDIN>'));
+    main::cmp_ok($pid, '>', 1, 'got a sane process ID');
+    main::ok(print WRITE "hi kid\n");
+    main::like(<KAZOP>, qr/^hi kid\r?\n$/);
+    main::ok(close(WRITE), "closing WRITE: $!");
+    main::ok(close(KAZOP), "closing READ: $!");
+    my $reaped_pid = waitpid $pid, 0;
+    main::is($reaped_pid, $pid, "Reaped PID matches");
+    main::is($?, 0, '$? should be zero');
+}
+
+$pid = eval { open2('READ', '', $perl, '-e', cmd_line('print scalar <STDIN>')) };
+like($@, qr/^open2: Modification of a read-only value attempted at /,
+     'open2 faults read-only parameters correctly') or do {waitpid $pid, 0};
diff --git a/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open3.t b/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open3.t
index 79d5cedde58..7b85b825e24 100755
--- a/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open3.t
+++ b/gnu/usr.bin/perl/ext/IPC-Open3/t/IPC-Open3.t
@@ -3,8 +3,8 @@
 BEGIN {
     require Config; import Config;
     if (!$Config{'d_fork'}
-       # open2/3 supported on win32 (but not Borland due to CRT bugs)
-       && (($^O ne 'MSWin32' && $^O ne 'NetWare') || $Config{'cc'} =~ /^bcc/i))
+       # open2/3 supported on win32
+       && $^O ne 'MSWin32' && $^O ne 'NetWare')
     {
 	print "1..0\n";
 	exit 0;
@@ -14,23 +14,13 @@ BEGIN {
 }
 
 use strict;
+use Test::More tests => 37;
+
 use IO::Handle;
 use IPC::Open3;
-#require 'open3.pl'; use subs 'open3';
 
 my $perl = $^X;
 
-sub ok {
-    my ($n, $result, $info) = @_;
-    if ($result) {
-	print "ok $n\n";
-    }
-    else {
-	print "not ok $n\n";
-	print "# $info\n" if $info;
-    }
-}
-
 sub cmd_line {
 	if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
 		my $cmd = shift;
@@ -47,102 +37,148 @@ my ($pid, $reaped_pid);
 STDOUT->autoflush;
 STDERR->autoflush;
 
-print "1..22\n";
-
 # basic
-ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF');
+$pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF');
     $| = 1;
     print scalar <STDIN>;
     print STDERR "hi error\n";
 EOF
-ok 2, print WRITE "hi kid\n";
-ok 3, <READ> =~ /^hi kid\r?\n$/;
-ok 4, <ERROR> =~ /^hi error\r?\n$/;
-ok 5, close(WRITE), $!;
-ok 6, close(READ), $!;
-ok 7, close(ERROR), $!;
+cmp_ok($pid, '!=', 0);
+isnt((print WRITE "hi kid\n"), 0);
+like(scalar <READ>, qr/^hi kid\r?\n$/);
+like(scalar <ERROR>, qr/^hi error\r?\n$/);
+is(close(WRITE), 1) or diag($!);
+is(close(READ), 1) or diag($!);
+is(close(ERROR), 1) or diag($!);
 $reaped_pid = waitpid $pid, 0;
-ok 8, $reaped_pid == $pid, $reaped_pid;
-ok 9, $? == 0, $?;
+is($reaped_pid, $pid);
+is($?, 0);
 
-# read and error together, both named
+my $desc = "read and error together, both named";
 $pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', cmd_line(<<'EOF');
     $| = 1;
     print scalar <STDIN>;
     print STDERR scalar <STDIN>;
 EOF
-print WRITE "ok 10\n";
-print scalar <READ>;
-print WRITE "ok 11\n";
-print scalar <READ>;
+print WRITE "$desc\n";
+like(scalar <READ>, qr/\A$desc\r?\n\z/);
+print WRITE "$desc [again]\n";
+like(scalar <READ>, qr/\A$desc \[again\]\r?\n\z/);
 waitpid $pid, 0;
 
-# read and error together, error empty
+$desc = "read and error together, error empty";
 $pid = open3 'WRITE', 'READ', '', $perl, '-e', cmd_line(<<'EOF');
     $| = 1;
     print scalar <STDIN>;
     print STDERR scalar <STDIN>;
 EOF
-print WRITE "ok 12\n";
-print scalar <READ>;
-print WRITE "ok 13\n";
-print scalar <READ>;
+print WRITE "$desc\n";
+like(scalar <READ>, qr/\A$desc\r?\n\z/);
+print WRITE "$desc [again]\n";
+like(scalar <READ>, qr/\A$desc \[again\]\r?\n\z/);
 waitpid $pid, 0;
 
-# dup writer
-ok 14, pipe PIPE_READ, PIPE_WRITE;
+is(pipe(PIPE_READ, PIPE_WRITE), 1);
 $pid = open3 '<&PIPE_READ', 'READ', '',
 		    $perl, '-e', cmd_line('print scalar <STDIN>');
 close PIPE_READ;
-print PIPE_WRITE "ok 15\n";
+print PIPE_WRITE "dup writer\n";
 close PIPE_WRITE;
-print scalar <READ>;
+like(scalar <READ>, qr/\Adup writer\r?\n\z/);
 waitpid $pid, 0;
 
+my $TB = Test::Builder->new();
+my $test = $TB->current_test;
 # dup reader
 $pid = open3 'WRITE', '>&STDOUT', 'ERROR',
 		    $perl, '-e', cmd_line('print scalar <STDIN>');
-print WRITE "ok 16\n";
+++$test;
+print WRITE "ok $test\n";
 waitpid $pid, 0;
 
+{
+    package YAAH;
+    $pid = IPC::Open3::open3('QWACK_WAAK_WAAK', '>&STDOUT', 'ERROR',
+			     $perl, '-e', main::cmd_line('print scalar <STDIN>'));
+    ++$test;
+    no warnings 'once';
+    print QWACK_WAAK_WAAK "ok $test # filenames qualified to their package\n";
+    waitpid $pid, 0;
+}
+
 # dup error:  This particular case, duping stderr onto the existing
 # stdout but putting stdout somewhere else, is a good case because it
 # used not to work.
 $pid = open3 'WRITE', 'READ', '>&STDOUT',
 		    $perl, '-e', cmd_line('print STDERR scalar <STDIN>');
-print WRITE "ok 17\n";
-waitpid $pid, 0;
-
-# dup reader and error together, both named
-$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $perl, '-e', cmd_line(<<'EOF');
-    $| = 1;
-    print STDOUT scalar <STDIN>;
-    print STDERR scalar <STDIN>;
-EOF
-print WRITE "ok 18\n";
-print WRITE "ok 19\n";
+++$test;
+print WRITE "ok $test\n";
 waitpid $pid, 0;
 
-# dup reader and error together, error empty
-$pid = open3 'WRITE', '>&STDOUT', '', $perl, '-e', cmd_line(<<'EOF');
+foreach (['>&STDOUT', 'both named'],
+	 ['', 'error empty'],
+	) {
+    my ($err, $desc) = @$_;
+    $pid = open3 'WRITE', '>&STDOUT', $err, $perl, '-e', cmd_line(<<'EOF');
     $| = 1;
     print STDOUT scalar <STDIN>;
     print STDERR scalar <STDIN>;
 EOF
-print WRITE "ok 20\n";
-print WRITE "ok 21\n";
-waitpid $pid, 0;
+    printf WRITE "ok %d # dup reader and error together, $desc\n", ++$test
+	for 0, 1;
+    waitpid $pid, 0;
+}
 
 # command line in single parameter variant of open3
 # for understanding of Config{'sh'} test see exec description in camel book
 my $cmd = 'print(scalar(<STDIN>))';
 $cmd = $Config{'sh'} =~ /sh/ ? "'$cmd'" : cmd_line($cmd);
-eval{$pid = open3 'WRITE', '>&STDOUT', 'ERROR', "$perl -e " . $cmd; };
+$pid = eval { open3 'WRITE', '>&STDOUT', 'ERROR', "$perl -e " . $cmd; };
 if ($@) {
 	print "error $@\n";
-	print "not ok 22\n";
+	++$test;
+	print WRITE "not ok $test\n";
 }
 else {
-	print WRITE "ok 22\n";
+	++$test;
+	print WRITE "ok $test\n";
 	waitpid $pid, 0;
 }
+$TB->current_test($test);
+
+# RT 72016
+{
+    local $::TODO = "$^O returns a pid and doesn't throw an exception"
+	if $^O eq 'MSWin32';
+    $pid = eval { open3 'WRITE', 'READ', 'ERROR', '/non/existent/program'; };
+    isnt($@, '',
+	 'open3 of a non existent program fails with an exception in the parent')
+	or do {waitpid $pid, 0};
+}
+
+$pid = eval { open3 'WRITE', '', 'ERROR', '/non/existent/program'; };
+like($@, qr/^open3: Modification of a read-only value attempted at /,
+     'open3 faults read-only parameters correctly') or do {waitpid $pid, 0};
+
+foreach my $handle (qw (DUMMY STDIN STDOUT STDERR)) {
+    local $::{$handle};
+    my $out = IO::Handle->new();
+    my $pid = eval {
+	local $SIG{__WARN__} = sub {
+	    open my $fh, '>/dev/tty';
+	    return if "@_" =~ m!^Use of uninitialized value \$fd.*IO/Handle\.pm!;
+	    print $fh "@_";
+	    die @_
+	};
+	open3 undef, $out, undef, $perl, '-le', "print q _# ${handle}_"
+    };
+    is($@, '', "No errors with localised $handle");
+    cmp_ok($pid, '>', 0, "Got a pid with localised $handle");
+    if ($handle eq 'STDOUT') {
+	is(<$out>, undef, "Expected no output with localised $handle");
+    } else {
+	like(<$out>, qr/\A# $handle\r?\n\z/,
+	     "Expected output with localised $handle");
+    }
+    waitpid $pid, 0;
+}
diff --git a/gnu/usr.bin/perl/ext/IPC-Open3/t/fd.t b/gnu/usr.bin/perl/ext/IPC-Open3/t/fd.t
new file mode 100644
index 00000000000..4e2742714dc
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IPC-Open3/t/fd.t
@@ -0,0 +1,45 @@
+#!./perl
+
+BEGIN {
+    if ($^O eq 'VMS') {
+        print "1..0 # Skip: needs porting, perhaps imitating Win32 mechanisms\n";
+	exit 0;
+    }
+    require "../../t/test.pl";
+}
+use strict;
+use warnings;
+
+plan 3;
+
+# [perl #76474]
+{
+  my $stderr = runperl(
+     switches => ['-MIPC::Open3', '-w'],
+     prog => 'open STDIN, q _Makefile_ or die $!; open3(q _<&0_, my $out, undef, $ENV{PERLEXE}, q _-e0_)',
+     stderr => 1,
+  );
+
+  is $stderr, '',
+   "dup STDOUT in a child process by using its file descriptor";
+}
+
+{
+  my $want = qr/\A# This Makefile is for the IPC::Open3 extension to perl\.\r?\z/;
+  open my $fh, '<', 'Makefile' or die "Can't open MAKEFILE: $!";
+  my $have = <$fh>;
+  chomp $have;
+  like($have, $want, 'No surprises from MakeMaker');
+  close $fh;
+
+  fresh_perl_like(<<'EOP',
+use IPC::Open3;
+open FOO, 'Makefile' or die $!;
+open3('<&' . fileno FOO, my $out, undef, $ENV{PERLEXE}, '-eprint scalar <STDIN>');
+print <$out>;
+EOP
+		  $want,
+		  undef,
+		  'Numeric file handles are duplicated correctly'
+      );
+}