Suppress a few compilation warnings in pp_hot.c.
[p5sagit/p5-mst-13.2.git] / t / io / pipe.t
CommitLineData
378cc40b 1#!./perl
2
774d564b 3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
774d564b 6 require Config; import Config;
b6345914 7 require './test.pl';
8
9 if (!$Config{'d_fork'}) {
10 skip_all("fork required to pipe");
11 }
12 else {
13 plan(tests => 22);
774d564b 14 }
15}
16
b6345914 17my $Perl = which_perl();
18
19
378cc40b 20$| = 1;
378cc40b 21
b6345914 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 28close PIPE;
29
b6345914 30SKIP: {
31 # Technically this should be TODO. Someone try it if you happen to
32 # have a vmesa machine.
33 skip "Doesn't work here yet", 4 if $^O eq 'vmesa';
34
092bebab 35 if (open(PIPE, "-|")) {
36 while(<PIPE>) {
37 s/^not //;
38 print;
39 }
b6345914 40 close PIPE; # avoid zombies
092bebab 41 }
42 else {
b6345914 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 50 # This has to be *outside* the fork
51 next_test() for 1..2;
52
53 SKIP: {
54 skip "fork required", 2 unless $Config{d_fork};
55
56 pipe(READER,WRITER) || die "Can't open pipe";
57
58 if ($pid = fork) {
59 close WRITER;
60 while(<READER>) {
61 s/^not //;
62 y/A-Z/a-z/;
63 print;
64 }
65 close READER; # avoid zombies
66 }
67 else {
68 die "Couldn't fork" unless defined $pid;
69 close READER;
70 printf WRITER "not ok %d - pipe & fork\n", curr_test;
71 next_test;
72
73 open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
74 close WRITER;
75
76 my $tnum = curr_test;
77 next_test;
78 exec $Perl, '-le', "print q{not ok $tnum - with fh dup }";
79 }
80
81 # This has to be done *outside* the fork.
82 next_test() for 1..2;
ac58e20f 83 }
b6345914 84}
d6a255e6 85wait; # Collect from $pid
ac58e20f 86
ac58e20f 87pipe(READER,WRITER) || die "Can't open pipe";
88close READER;
89
90$SIG{'PIPE'} = 'broken_pipe';
91
92sub broken_pipe {
1d2dff63 93 $SIG{'PIPE'} = 'IGNORE'; # loop preventer
b6345914 94 printf "ok %d - SIGPIPE\n", curr_test;
ac58e20f 95}
96
b6345914 97printf WRITER "not ok %d - SIGPIPE\n", curr_test;
ac58e20f 98close WRITER;
3d57aefb 99sleep 1;
b6345914 100next_test;
101pass();
03136e13 102
103# VMS doesn't like spawning subprocesses that are still connected to
b6345914 104# STDOUT. Someone should modify these tests to work with VMS.
105
106SKIP: {
107 skip "doesn't like spawning subprocesses that are still connected", 10
108 if $^O eq 'VMS';
109
110 SKIP: {
111 # Sfio doesn't report failure when closing a broken pipe
112 # that has pending output. Go figure. MachTen doesn't either,
113 # but won't write to broken pipes, so nothing's pending at close.
114 # BeOS will not write to broken pipes, either.
115 # Nor does POSIX-BC.
116 skip "Won't report failure on broken pipe", 1
117 if $Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' ||
118 $^O eq 'posix-bc';
119
120 local $SIG{PIPE} = 'IGNORE';
121 open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
122 sleep 5;
123 if (print NIL 'foo') {
124 # If print was allowed we had better get an error on close
125 ok( !close NIL, 'close error on broken pipe' );
126 }
127 else {
128 ok(close NIL, 'print failed on broken pipe');
129 }
03136e13 130 }
03136e13 131
b6345914 132 SKIP: {
133 skip "Don't work yet", 9 if $^O eq 'vmesa';
134
135 # check that errno gets forced to 0 if the piped program exited
136 # non-zero
137 open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
138 $! = 1;
139 ok(!close NIL, 'close failure on non-zero piped exit');
140 is($!, '', ' errno');
141 isnt($?, 0, ' status');
142
143 SKIP: {
144 skip "Don't work yet", 6 if $^O eq 'mpeix';
145
146 # check that status for the correct process is collected
147 my $zombie;
148 unless( $zombie = fork ) {
149 $NO_ENDING=1;
150 exit 37;
151 }
152 my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
153 $SIG{ALRM} = sub { return };
154 alarm(1);
155 is( close FH, '', 'close failure for... umm, something' );
156 is( $?, 13*256, ' status' );
157 is( $!, '', ' errno');
158
159 my $wait = wait;
160 is( $?, 37*256, 'status correct after wait' );
161 is( $wait, $zombie, ' wait pid' );
162 is( $!, '', ' errno');
163 }
0994c4d0 164 }
1d3434b8 165}
06eaf0bc 166
167# Test new semantics for missing command in piped open
168# 19990114 M-J. Dominus mjd@plover.com
169{ local *P;
b6345914 170 ok( !open(P, "| "), 'missing command in piped open input' );
171 ok( !open(P, " |"), ' output');
06eaf0bc 172}
f2b5be74 173
174# check that status is unaffected by implicit close
175{
176 local(*NIL);
b6345914 177 open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
f2b5be74 178 $? = 42;
179 # NIL implicitly closed here
180}
b6345914 181is($?, 42, 'status unaffected by implicit close');
f2b5be74 182$? = 0;
faa466a7 183
184# check that child is reaped if the piped program can't be executed
185{
faa466a7 186 open NIL, '/no_such_process |';
187 close NIL;
188
189 my $child = 0;
190 eval {
191 local $SIG{ALRM} = sub { die; };
192 alarm 2;
193 $child = wait;
194 alarm 0;
195 };
196
b6345914 197 is($child, -1, 'child reaped if piped program cannot be executed');
faa466a7 198}