Commit | Line | Data |
---|---|---|
7e1af8bc | 1 | #!./perl -w |
7e1af8bc | 2 | |
3 | BEGIN { | |
774d564b | 4 | require Config; import Config; |
f55ee38a | 5 | if (!$Config{'d_fork'} |
378eeda7 SH |
6 | # open2/3 supported on win32 |
7 | && $^O ne 'MSWin32' && $^O ne 'NetWare') | |
f55ee38a | 8 | { |
774d564b | 9 | print "1..0\n"; |
10 | exit 0; | |
11 | } | |
7e1af8bc | 12 | # make warnings fatal |
13 | $SIG{__WARN__} = sub { die @_ }; | |
14 | } | |
15 | ||
71be2cbc | 16 | use strict; |
031f91ce | 17 | use Test::More tests => 37; |
bd29e8c2 | 18 | |
7e1af8bc | 19 | use IO::Handle; |
20 | use IPC::Open3; | |
7e1af8bc | 21 | |
945d6bad | 22 | my $perl = $^X; |
774d564b | 23 | |
f55ee38a | 24 | sub cmd_line { |
2986a63f | 25 | if ($^O eq 'MSWin32' || $^O eq 'NetWare') { |
f55ee38a GS |
26 | my $cmd = shift; |
27 | $cmd =~ tr/\r\n//d; | |
28 | $cmd =~ s/"/\\"/g; | |
29 | return qq/"$cmd"/; | |
30 | } | |
31 | else { | |
32 | return $_[0]; | |
33 | } | |
34 | } | |
35 | ||
7e1af8bc | 36 | my ($pid, $reaped_pid); |
37 | STDOUT->autoflush; | |
38 | STDERR->autoflush; | |
39 | ||
7e1af8bc | 40 | # basic |
bd29e8c2 | 41 | $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF'); |
7e1af8bc | 42 | $| = 1; |
43 | print scalar <STDIN>; | |
44 | print STDERR "hi error\n"; | |
45 | EOF | |
bd29e8c2 NC |
46 | cmp_ok($pid, '!=', 0); |
47 | isnt((print WRITE "hi kid\n"), 0); | |
48 | like(scalar <READ>, qr/^hi kid\r?\n$/); | |
49 | like(scalar <ERROR>, qr/^hi error\r?\n$/); | |
50 | is(close(WRITE), 1) or diag($!); | |
51 | is(close(READ), 1) or diag($!); | |
52 | is(close(ERROR), 1) or diag($!); | |
7e1af8bc | 53 | $reaped_pid = waitpid $pid, 0; |
bd29e8c2 NC |
54 | is($reaped_pid, $pid); |
55 | is($?, 0); | |
7e1af8bc | 56 | |
bd29e8c2 | 57 | my $desc = "read and error together, both named"; |
f55ee38a | 58 | $pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', cmd_line(<<'EOF'); |
7e1af8bc | 59 | $| = 1; |
60 | print scalar <STDIN>; | |
61 | print STDERR scalar <STDIN>; | |
62 | EOF | |
bd29e8c2 | 63 | print WRITE "$desc\n"; |
589b000b | 64 | like(scalar <READ>, qr/\A$desc\r?\n\z/); |
bd29e8c2 | 65 | print WRITE "$desc [again]\n"; |
589b000b | 66 | like(scalar <READ>, qr/\A$desc \[again\]\r?\n\z/); |
7e1af8bc | 67 | waitpid $pid, 0; |
68 | ||
bd29e8c2 | 69 | $desc = "read and error together, error empty"; |
f55ee38a | 70 | $pid = open3 'WRITE', 'READ', '', $perl, '-e', cmd_line(<<'EOF'); |
7e1af8bc | 71 | $| = 1; |
72 | print scalar <STDIN>; | |
73 | print STDERR scalar <STDIN>; | |
74 | EOF | |
bd29e8c2 | 75 | print WRITE "$desc\n"; |
589b000b | 76 | like(scalar <READ>, qr/\A$desc\r?\n\z/); |
bd29e8c2 | 77 | print WRITE "$desc [again]\n"; |
589b000b | 78 | like(scalar <READ>, qr/\A$desc \[again\]\r?\n\z/); |
7e1af8bc | 79 | waitpid $pid, 0; |
80 | ||
bd29e8c2 | 81 | is(pipe(PIPE_READ, PIPE_WRITE), 1); |
7e1af8bc | 82 | $pid = open3 '<&PIPE_READ', 'READ', '', |
f55ee38a | 83 | $perl, '-e', cmd_line('print scalar <STDIN>'); |
7e1af8bc | 84 | close PIPE_READ; |
bd29e8c2 | 85 | print PIPE_WRITE "dup writer\n"; |
7e1af8bc | 86 | close PIPE_WRITE; |
589b000b | 87 | like(scalar <READ>, qr/\Adup writer\r?\n\z/); |
7e1af8bc | 88 | waitpid $pid, 0; |
89 | ||
bd29e8c2 NC |
90 | my $TB = Test::Builder->new(); |
91 | my $test = $TB->current_test; | |
7e1af8bc | 92 | # dup reader |
93 | $pid = open3 'WRITE', '>&STDOUT', 'ERROR', | |
f55ee38a | 94 | $perl, '-e', cmd_line('print scalar <STDIN>'); |
bd29e8c2 NC |
95 | ++$test; |
96 | print WRITE "ok $test\n"; | |
7e1af8bc | 97 | waitpid $pid, 0; |
98 | ||
479ddbbe NC |
99 | { |
100 | package YAAH; | |
101 | $pid = IPC::Open3::open3('QWACK_WAAK_WAAK', '>&STDOUT', 'ERROR', | |
102 | $perl, '-e', main::cmd_line('print scalar <STDIN>')); | |
103 | ++$test; | |
104 | no warnings 'once'; | |
105 | print QWACK_WAAK_WAAK "ok $test # filenames qualified to their package\n"; | |
106 | waitpid $pid, 0; | |
107 | } | |
108 | ||
7e1af8bc | 109 | # dup error: This particular case, duping stderr onto the existing |
110 | # stdout but putting stdout somewhere else, is a good case because it | |
111 | # used not to work. | |
112 | $pid = open3 'WRITE', 'READ', '>&STDOUT', | |
f55ee38a | 113 | $perl, '-e', cmd_line('print STDERR scalar <STDIN>'); |
bd29e8c2 NC |
114 | ++$test; |
115 | print WRITE "ok $test\n"; | |
7e1af8bc | 116 | waitpid $pid, 0; |
117 | ||
25dd7e89 NC |
118 | foreach (['>&STDOUT', 'both named'], |
119 | ['', 'error empty'], | |
120 | ) { | |
121 | my ($err, $desc) = @$_; | |
122 | $pid = open3 'WRITE', '>&STDOUT', $err, $perl, '-e', cmd_line(<<'EOF'); | |
7e1af8bc | 123 | $| = 1; |
124 | print STDOUT scalar <STDIN>; | |
125 | print STDERR scalar <STDIN>; | |
126 | EOF | |
25dd7e89 NC |
127 | printf WRITE "ok %d # dup reader and error together, $desc\n", ++$test |
128 | for 0, 1; | |
129 | waitpid $pid, 0; | |
130 | } | |
7083d4d1 GS |
131 | |
132 | # command line in single parameter variant of open3 | |
133 | # for understanding of Config{'sh'} test see exec description in camel book | |
134 | my $cmd = 'print(scalar(<STDIN>))'; | |
135 | $cmd = $Config{'sh'} =~ /sh/ ? "'$cmd'" : cmd_line($cmd); | |
8025b67f | 136 | $pid = eval { open3 'WRITE', '>&STDOUT', 'ERROR', "$perl -e " . $cmd; }; |
7083d4d1 GS |
137 | if ($@) { |
138 | print "error $@\n"; | |
bd29e8c2 NC |
139 | ++$test; |
140 | print WRITE "not ok $test\n"; | |
7083d4d1 GS |
141 | } |
142 | else { | |
bd29e8c2 NC |
143 | ++$test; |
144 | print WRITE "ok $test\n"; | |
7083d4d1 | 145 | waitpid $pid, 0; |
85e4d853 | 146 | } |
bd29e8c2 | 147 | $TB->current_test($test); |
bb5bc496 EB |
148 | |
149 | # RT 72016 | |
8025b67f NC |
150 | { |
151 | local $::TODO = "$^O returns a pid and doesn't throw an exception" | |
152 | if $^O eq 'MSWin32'; | |
153 | $pid = eval { open3 'WRITE', 'READ', 'ERROR', '/non/existent/program'; }; | |
154 | isnt($@, '', | |
155 | 'open3 of a non existent program fails with an exception in the parent') | |
156 | or do {waitpid $pid, 0}; | |
bb5bc496 | 157 | } |
a1157350 NC |
158 | |
159 | $pid = eval { open3 'WRITE', '', 'ERROR', '/non/existent/program'; }; | |
160 | like($@, qr/^open3: Modification of a read-only value attempted at /, | |
161 | 'open3 faults read-only parameters correctly') or do {waitpid $pid, 0}; | |
031f91ce NC |
162 | |
163 | foreach my $handle (qw (DUMMY STDIN STDOUT STDERR)) { | |
164 | local $::{$handle}; | |
165 | my $out = IO::Handle->new(); | |
166 | my $pid = eval { | |
167 | local $SIG{__WARN__} = sub { | |
168 | open my $fh, '>/dev/tty'; | |
169 | return if "@_" =~ m!^Use of uninitialized value \$fd.*IO/Handle\.pm!; | |
170 | print $fh "@_"; | |
171 | die @_ | |
172 | }; | |
173 | open3 undef, $out, undef, $perl, '-le', "print q _# ${handle}_" | |
174 | }; | |
175 | is($@, '', "No errors with localised $handle"); | |
176 | cmp_ok($pid, '>', 0, "Got a pid with localised $handle"); | |
177 | if ($handle eq 'STDOUT') { | |
178 | is(<$out>, undef, "Expected no output with localised $handle"); | |
179 | } else { | |
180 | like(<$out>, qr/\A# $handle\r?\n\z/, | |
181 | "Expected output with localised $handle"); | |
182 | } | |
183 | waitpid $pid, 0; | |
184 | } |