1#!./perl -w
2
3BEGIN {
4    require Config; import Config;
5    if (!$Config{'d_fork'}
6       # open2/3 supported on win32
7       && $^O ne 'MSWin32')
8    {
9	print "1..0\n";
10	exit 0;
11    }
12    # make warnings fatal
13    $SIG{__WARN__} = sub { die @_ };
14}
15
16use strict;
17use Test::More tests => 45;
18
19use IO::Handle;
20use IPC::Open3;
21use POSIX ":sys_wait_h";
22
23my $perl = $^X;
24
25sub cmd_line {
26	if ($^O eq 'MSWin32') {
27		my $cmd = shift;
28		$cmd =~ tr/\r\n//d;
29		$cmd =~ s/"/\\"/g;
30		return qq/"$cmd"/;
31	}
32	else {
33		return $_[0];
34	}
35}
36
37my ($pid, $reaped_pid);
38STDOUT->autoflush;
39STDERR->autoflush;
40
41# basic
42$pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF');
43    $| = 1;
44    print scalar <STDIN>;
45    print STDERR "hi error\n";
46EOF
47cmp_ok($pid, '!=', 0);
48isnt((print WRITE "hi kid\n"), 0);
49like(scalar <READ>, qr/^hi kid\r?\n$/);
50like(scalar <ERROR>, qr/^hi error\r?\n$/);
51is(close(WRITE), 1) or diag($!);
52is(close(READ), 1) or diag($!);
53is(close(ERROR), 1) or diag($!);
54$reaped_pid = waitpid $pid, 0;
55is($reaped_pid, $pid);
56is($?, 0);
57
58my $desc = "read and error together, both named";
59$pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', cmd_line(<<'EOF');
60    $| = 1;
61    print scalar <STDIN>;
62    print STDERR scalar <STDIN>;
63EOF
64print WRITE "$desc\n";
65like(scalar <READ>, qr/\A$desc\r?\n\z/);
66print WRITE "$desc [again]\n";
67like(scalar <READ>, qr/\A$desc \[again\]\r?\n\z/);
68waitpid $pid, 0;
69
70$desc = "read and error together, error empty";
71$pid = open3 'WRITE', 'READ', '', $perl, '-e', cmd_line(<<'EOF');
72    $| = 1;
73    print scalar <STDIN>;
74    print STDERR scalar <STDIN>;
75EOF
76print WRITE "$desc\n";
77like(scalar <READ>, qr/\A$desc\r?\n\z/);
78print WRITE "$desc [again]\n";
79like(scalar <READ>, qr/\A$desc \[again\]\r?\n\z/);
80waitpid $pid, 0;
81
82is(pipe(PIPE_READ, PIPE_WRITE), 1);
83$pid = open3 '<&PIPE_READ', 'READ', '',
84		    $perl, '-e', cmd_line('print scalar <STDIN>');
85close PIPE_READ;
86print PIPE_WRITE "dup writer\n";
87close PIPE_WRITE;
88like(scalar <READ>, qr/\Adup writer\r?\n\z/);
89waitpid $pid, 0;
90
91my $TB = Test::Builder->new();
92my $test = $TB->current_test;
93# dup reader
94$pid = open3 'WRITE', '>&STDOUT', 'ERROR',
95		    $perl, '-e', cmd_line('print scalar <STDIN>');
96++$test;
97print WRITE "ok $test\n";
98waitpid $pid, 0;
99
100{
101    package YAAH;
102    $pid = IPC::Open3::open3('QWACK_WAAK_WAAK', '>&STDOUT', 'ERROR',
103			     $perl, '-e', main::cmd_line('print scalar <STDIN>'));
104    ++$test;
105    no warnings 'once';
106    print QWACK_WAAK_WAAK "ok $test # filenames qualified to their package\n";
107    waitpid $pid, 0;
108}
109
110# dup error:  This particular case, duping stderr onto the existing
111# stdout but putting stdout somewhere else, is a good case because it
112# used not to work.
113$pid = open3 'WRITE', 'READ', '>&STDOUT',
114		    $perl, '-e', cmd_line('print STDERR scalar <STDIN>');
115++$test;
116print WRITE "ok $test\n";
117waitpid $pid, 0;
118
119foreach (['>&STDOUT', 'both named'],
120	 ['', 'error empty'],
121	) {
122    my ($err, $desc) = @$_;
123    $pid = open3 'WRITE', '>&STDOUT', $err, $perl, '-e', cmd_line(<<'EOF');
124    $| = 1;
125    print STDOUT scalar <STDIN>;
126    print STDERR scalar <STDIN>;
127EOF
128    printf WRITE "ok %d # dup reader and error together, $desc\n", ++$test
129	for 0, 1;
130    waitpid $pid, 0;
131}
132
133# command line in single parameter variant of open3
134# for understanding of Config{'sh'} test see exec description in camel book
135my $cmd = 'print(scalar(<STDIN>))';
136$cmd = $Config{'sh'} =~ /sh/ ? "'$cmd'" : cmd_line($cmd);
137$pid = eval { open3 'WRITE', '>&STDOUT', 'ERROR', "$perl -e " . $cmd; };
138if ($@) {
139	print "error $@\n";
140	++$test;
141	print WRITE "not ok $test\n";
142}
143else {
144	++$test;
145	print WRITE "ok $test\n";
146	waitpid $pid, 0;
147}
148$TB->current_test($test);
149
150# RT 72016
151{
152    local $::TODO = "$^O returns a pid and doesn't throw an exception"
153	if $^O eq 'MSWin32';
154    $pid = eval { open3 'WRITE', 'READ', 'ERROR', '/non/existent/program'; };
155    isnt($@, '',
156	 'open3 of a non existent program fails with an exception in the parent')
157	or do {waitpid $pid, 0};
158    SKIP: {
159	skip 'open3 returned, our responsibility to reap', 1 unless $@;
160	is(waitpid(-1, WNOHANG), -1, 'failed exec child is reaped');
161    }
162}
163
164$pid = eval { open3 'WRITE', '', 'ERROR', '/non/existent/program'; };
165like($@, qr/^open3: Modification of a read-only value attempted at /,
166     'open3 faults read-only parameters correctly') or do {waitpid $pid, 0};
167
168package NoFetch;
169
170my $fetchcount = 1;
171
172sub TIESCALAR {
173  my $class = shift;
174  my $instance = shift || undef;
175  return bless \$instance => $class;
176}
177
178sub FETCH {
179    my $cmd; #dont let "@args = @DB::args;" in Carp::caller_info fire this die
180    #fetchcount may need to be increased to 2 if this code is being stepped with
181    #a perl debugger
182    if($fetchcount == 1 && (caller(1))[3] ne 'Carp::caller_info') {
183	#Carp croak reports the errors as being in IPC-Open3.t, so it is
184	#unacceptable for testing where the FETCH failure occured, we dont want
185	#it failing in a $foo = $_[0]; #later# system($foo), where the failure
186	#is supposed to be triggered in the inner most syscall, aka system()
187	my ($package, $filename, $line, $subroutine) = caller(2);
188
189	die("FETCH not allowed in ".((caller(1))[3])." in ".((caller(2))[3])."\n");
190    } else {
191	$fetchcount++;
192	return tie($cmd, 'NoFetch');
193    }
194}
195
196package main;
197
198{
199    my $cmd;
200    tie($cmd, 'NoFetch');
201
202    $pid = eval { open3 'WRITE', 'READ', 'ERROR', $cmd; };
203    like($@, qr/^(?:open3: IO::Pipe: Can't spawn-NOWAIT: FETCH not allowed in \(eval\) (?x:
204         )in IPC::Open3::spawn_with_handles|FETCH not allowed in \(eval\) in IPC::Open3::_open3)/,
205     'dieing inside Tied arg propagates correctly') or do {waitpid $pid, 0};
206}
207
208foreach my $handle (qw (DUMMY STDIN STDOUT STDERR)) {
209    local $::{$handle};
210    my $out = IO::Handle->new();
211    my $pid = eval {
212	local $SIG{__WARN__} = sub {
213	    open my $fh, '>', '/dev/tty';
214	    return if "@_" =~ m!^Use of uninitialized value \$fd.*IO/Handle\.pm!;
215	    print $fh "@_";
216	    die @_
217	};
218	open3 undef, $out, undef, $perl, '-le', "print q _# ${handle}_"
219    };
220    is($@, '', "No errors with localised $handle");
221    cmp_ok($pid, '>', 0, "Got a pid with localised $handle");
222    if ($handle eq 'STDOUT') {
223	is(<$out>, undef, "Expected no output with localised $handle");
224    } else {
225	like(<$out>, qr/\A# $handle\r?\n\z/,
226	     "Expected output with localised $handle");
227    }
228    waitpid $pid, 0;
229}
230
231# Test that tied STDIN, STDOUT, and STDERR do not cause open3 any discomfort.
232# In particular, tied STDERR used to be able to prevent open3 from working
233# correctly.  RT #119843.
234SKIP: {
235    if (&IPC::Open3::DO_SPAWN) {
236      skip "Calling open3 with tied filehandles does not work here", 6
237    }
238
239    {	# This just throws things out
240	package My::Tied::FH;
241	sub TIEHANDLE { bless \my $self }
242	sub PRINT {}
243	# Note the absence of OPEN and FILENO
244    }
245    my $message = "japh\n";
246    foreach my $handle (*STDIN, *STDOUT, *STDERR) {
247	tie $handle, 'My::Tied::FH';
248	my ($in, $out);
249	my $pid = eval {
250	    open3 $in, $out, undef, $perl, '-ne', 'print';
251	};
252	is($@, '', "no errors calling open3 with tied $handle");
253	print $in $message;
254	close $in;
255	my $japh = <$out>;
256	waitpid $pid, 0;
257	is($japh, $message, "read input correctly");
258	untie $handle;
259    }
260}
261