This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Text mode wrongly set on pipe file descriptors
[perl5.git] / t / io / pipe.t
CommitLineData
378cc40b
LW
1#!./perl
2
774d564b
PP
3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
774d564b 6 require Config; import Config;
b6345914
JH
7 require './test.pl';
8
9 if (!$Config{'d_fork'}) {
10 skip_all("fork required to pipe");
11 }
12 else {
713cef20 13 plan(tests => 24);
774d564b
PP
14 }
15}
16
b6345914
JH
17my $Perl = which_perl();
18
19
378cc40b 20$| = 1;
378cc40b 21
b6345914
JH
22open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/';
23
24printf PIPE "Xk %d - open |- || exec\n", curr_test();
25next_test();
26printf PIPE "oY %d - again\n", curr_test();
27next_test();
378cc40b
LW
28close PIPE;
29
b6345914
JH
30SKIP: {
31 # Technically this should be TODO. Someone try it if you happen to
32 # have a vmesa machine.
713cef20 33 skip "Doesn't work here yet", 6 if $^O eq 'vmesa';
b6345914 34
092bebab
JH
35 if (open(PIPE, "-|")) {
36 while(<PIPE>) {
37 s/^not //;
38 print;
39 }
b6345914 40 close PIPE; # avoid zombies
092bebab
JH
41 }
42 else {
b6345914
JH
43 printf STDOUT "not ok %d - open -|\n", curr_test();
44 next_test();
45 my $tnum = curr_test;
46 next_test();
47 exec $Perl, '-le', "print q{not ok $tnum - again}";
378cc40b 48 }
ac58e20f 49
b6345914
JH
50 # This has to be *outside* the fork
51 next_test() for 1..2;
52
713cef20
IZ
53 my $raw = "abc\nrst\rxyz\r\nfoo\n";
54 if (open(PIPE, "-|")) {
55 $_ = join '', <PIPE>;
56 (my $raw1 = $_) =~ s/not ok \d+ - //;
57 my @r = map ord, split //, $raw;
58 my @r1 = map ord, split //, $raw1;
59 if ($raw1 eq $raw) {
60 s/^not (ok \d+ -) .*/$1 '@r1' passes through '-|'\n/s;
61 } else {
62 s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s;
63 }
64 print;
65 close PIPE; # avoid zombies
66 }
67 else {
68 printf STDOUT "not ok %d - $raw", curr_test();
69 exec $Perl, '-e0'; # Do not run END()...
70 }
71
72 # This has to be *outside* the fork
73 next_test();
74
75 if (open(PIPE, "|-")) {
76 printf PIPE "not ok %d - $raw", curr_test();
77 close PIPE; # avoid zombies
78 }
79 else {
80 $_ = join '', <STDIN>;
81 (my $raw1 = $_) =~ s/not ok \d+ - //;
82 my @r = map ord, split //, $raw;
83 my @r1 = map ord, split //, $raw1;
84 if ($raw1 eq $raw) {
85 s/^not (ok \d+ -) .*/$1 '@r1' passes through '|-'\n/s;
86 } else {
87 s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s;
88 }
89 print;
90 exec $Perl, '-e0'; # Do not run END()...
91 }
92
93 # This has to be *outside* the fork
94 next_test();
95
b6345914
JH
96 SKIP: {
97 skip "fork required", 2 unless $Config{d_fork};
98
99 pipe(READER,WRITER) || die "Can't open pipe";
100
101 if ($pid = fork) {
102 close WRITER;
103 while(<READER>) {
104 s/^not //;
105 y/A-Z/a-z/;
106 print;
107 }
108 close READER; # avoid zombies
109 }
110 else {
111 die "Couldn't fork" unless defined $pid;
112 close READER;
113 printf WRITER "not ok %d - pipe & fork\n", curr_test;
114 next_test;
115
116 open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
117 close WRITER;
118
119 my $tnum = curr_test;
120 next_test;
121 exec $Perl, '-le', "print q{not ok $tnum - with fh dup }";
122 }
123
124 # This has to be done *outside* the fork.
125 next_test() for 1..2;
ac58e20f 126 }
b6345914 127}
d6a255e6 128wait; # Collect from $pid
ac58e20f 129
ac58e20f
LW
130pipe(READER,WRITER) || die "Can't open pipe";
131close READER;
132
133$SIG{'PIPE'} = 'broken_pipe';
134
135sub broken_pipe {
1d2dff63 136 $SIG{'PIPE'} = 'IGNORE'; # loop preventer
b6345914 137 printf "ok %d - SIGPIPE\n", curr_test;
ac58e20f
LW
138}
139
b6345914 140printf WRITER "not ok %d - SIGPIPE\n", curr_test;
ac58e20f 141close WRITER;
3d57aefb 142sleep 1;
b6345914
JH
143next_test;
144pass();
03136e13
CS
145
146# VMS doesn't like spawning subprocesses that are still connected to
b6345914
JH
147# STDOUT. Someone should modify these tests to work with VMS.
148
149SKIP: {
150 skip "doesn't like spawning subprocesses that are still connected", 10
151 if $^O eq 'VMS';
152
153 SKIP: {
154 # Sfio doesn't report failure when closing a broken pipe
155 # that has pending output. Go figure. MachTen doesn't either,
156 # but won't write to broken pipes, so nothing's pending at close.
157 # BeOS will not write to broken pipes, either.
158 # Nor does POSIX-BC.
159 skip "Won't report failure on broken pipe", 1
160 if $Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' ||
161 $^O eq 'posix-bc';
162
163 local $SIG{PIPE} = 'IGNORE';
164 open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
165 sleep 5;
166 if (print NIL 'foo') {
167 # If print was allowed we had better get an error on close
168 ok( !close NIL, 'close error on broken pipe' );
169 }
170 else {
171 ok(close NIL, 'print failed on broken pipe');
172 }
03136e13 173 }
03136e13 174
b6345914
JH
175 SKIP: {
176 skip "Don't work yet", 9 if $^O eq 'vmesa';
177
178 # check that errno gets forced to 0 if the piped program exited
179 # non-zero
180 open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
181 $! = 1;
182 ok(!close NIL, 'close failure on non-zero piped exit');
183 is($!, '', ' errno');
184 isnt($?, 0, ' status');
185
186 SKIP: {
187 skip "Don't work yet", 6 if $^O eq 'mpeix';
188
189 # check that status for the correct process is collected
190 my $zombie;
191 unless( $zombie = fork ) {
192 $NO_ENDING=1;
193 exit 37;
194 }
195 my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
196 $SIG{ALRM} = sub { return };
197 alarm(1);
198 is( close FH, '', 'close failure for... umm, something' );
199 is( $?, 13*256, ' status' );
200 is( $!, '', ' errno');
201
202 my $wait = wait;
203 is( $?, 37*256, 'status correct after wait' );
204 is( $wait, $zombie, ' wait pid' );
205 is( $!, '', ' errno');
206 }
0994c4d0 207 }
1d3434b8 208}
06eaf0bc
GS
209
210# Test new semantics for missing command in piped open
211# 19990114 M-J. Dominus mjd@plover.com
212{ local *P;
3fb41248 213 no warnings 'pipe';
b6345914
JH
214 ok( !open(P, "| "), 'missing command in piped open input' );
215 ok( !open(P, " |"), ' output');
06eaf0bc 216}
f2b5be74
GS
217
218# check that status is unaffected by implicit close
219{
220 local(*NIL);
b6345914 221 open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
f2b5be74
GS
222 $? = 42;
223 # NIL implicitly closed here
224}
b6345914 225is($?, 42, 'status unaffected by implicit close');
f2b5be74 226$? = 0;
faa466a7
RG
227
228# check that child is reaped if the piped program can't be executed
38efdb82
SP
229SKIP: {
230 skip "/no_such_process exists", 1 if -e "/no_such_process";
faa466a7
RG
231 open NIL, '/no_such_process |';
232 close NIL;
233
234 my $child = 0;
235 eval {
236 local $SIG{ALRM} = sub { die; };
237 alarm 2;
238 $child = wait;
239 alarm 0;
240 };
241
b6345914 242 is($child, -1, 'child reaped if piped program cannot be executed');
faa466a7 243}