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