5 require Config; import Config;
9 if (!$Config{'d_fork'}) {
10 skip_all("fork required to pipe");
16 my $Perl = which_perl();
21 open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/';
23 printf PIPE "Xk %d - open |- || exec\n", curr_test();
25 printf PIPE "oY %d - again\n", curr_test();
30 if (open(PIPE, "-|")) {
35 close PIPE; # avoid zombies
38 printf STDOUT "not ok %d - open -|\n", curr_test();
42 exec $Perl, '-le', "print q{not ok $tnum - again}";
45 # This has to be *outside* the fork
48 my $raw = "abc\nrst\rxyz\r\nfoo\n";
49 if (open(PIPE, "-|")) {
51 (my $raw1 = $_) =~ s/not ok \d+ - //;
52 my @r = map ord, split //, $raw;
53 my @r1 = map ord, split //, $raw1;
55 s/^not (ok \d+ -) .*/$1 '@r1' passes through '-|'\n/s;
57 s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s;
60 close PIPE; # avoid zombies
63 printf STDOUT "not ok %d - $raw", curr_test();
64 exec $Perl, '-e0'; # Do not run END()...
67 # This has to be *outside* the fork
70 if (open(PIPE, "|-")) {
71 printf PIPE "not ok %d - $raw", curr_test();
72 close PIPE; # avoid zombies
75 $_ = join '', <STDIN>;
76 (my $raw1 = $_) =~ s/not ok \d+ - //;
77 my @r = map ord, split //, $raw;
78 my @r1 = map ord, split //, $raw1;
80 s/^not (ok \d+ -) .*/$1 '@r1' passes through '|-'\n/s;
82 s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s;
85 exec $Perl, '-e0'; # Do not run END()...
88 # This has to be *outside* the fork
92 skip "fork required", 2 unless $Config{d_fork};
94 pipe(READER,WRITER) || die "Can't open pipe";
103 close READER; # avoid zombies
106 die "Couldn't fork" unless defined $pid;
108 printf WRITER "not ok %d - pipe & fork\n", curr_test;
111 open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
114 my $tnum = curr_test;
116 exec $Perl, '-le', "print q{not ok $tnum - with fh dup }";
119 # This has to be done *outside* the fork.
120 next_test() for 1..2;
123 wait; # Collect from $pid
125 pipe(READER,WRITER) || die "Can't open pipe";
128 $SIG{'PIPE'} = 'broken_pipe';
131 $SIG{'PIPE'} = 'IGNORE'; # loop preventer
132 printf "ok %d - SIGPIPE\n", curr_test;
135 printf WRITER "not ok %d - SIGPIPE\n", curr_test;
141 # VMS doesn't like spawning subprocesses that are still connected to
142 # STDOUT. Someone should modify these tests to work with VMS.
145 skip "doesn't like spawning subprocesses that are still connected", 10
149 # POSIX-BC doesn't report failure when closing a broken pipe
150 # that has pending output. Go figure.
151 skip "Won't report failure on broken pipe", 1
152 if $^O eq 'posix-bc';
154 local $SIG{PIPE} = 'IGNORE';
155 open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
157 if (print NIL 'foo') {
158 # If print was allowed we had better get an error on close
159 ok( !close NIL, 'close error on broken pipe' );
162 ok(close NIL, 'print failed on broken pipe');
167 # check that errno gets forced to 0 if the piped program exited
169 open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
171 ok(!close NIL, 'close failure on non-zero piped exit');
172 is($!, '', ' errno');
173 isnt($?, 0, ' status');
177 # check that status for the correct process is collected
179 unless( $zombie = fork ) {
183 my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
184 $SIG{ALRM} = sub { return };
186 is( close FH, '', 'close failure for... umm, something' );
187 is( $?, 13*256, ' status' );
188 is( $!, '', ' errno');
191 is( $?, 37*256, 'status correct after wait' );
192 is( $wait, $zombie, ' wait pid' );
193 is( $!, '', ' errno');
198 # Test new semantics for missing command in piped open
199 # 19990114 M-J. Dominus mjd@plover.com
202 ok( !open(P, "| "), 'missing command in piped open input' );
203 ok( !open(P, " |"), ' output');
206 # check that status is unaffected by implicit close
209 open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
211 # NIL implicitly closed here
213 is($?, 42, 'status unaffected by implicit close');
216 # check that child is reaped if the piped program can't be executed
218 skip "/no_such_process exists", 1 if -e "/no_such_process";
219 open NIL, '/no_such_process |';
224 local $SIG{ALRM} = sub { die; };
230 is($child, -1, 'child reaped if piped program cannot be executed');