1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require Config; import Config; 6 require './test.pl'; 7 set_up_inc('../lib'); 8} 9if (!$Config{'d_fork'}) { 10 skip_all("fork required to pipe"); 11} 12else { 13 plan(tests => 27); 14} 15 16my $Perl = which_perl(); 17 18 19$| = 1; 20 21open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/'; 22 23printf PIPE "Xk %d - open |- || exec\n", curr_test(); 24next_test(); 25printf PIPE "oY %d - again\n", curr_test(); 26next_test(); 27close PIPE; 28 29{ 30 if (open(PIPE, "-|")) { 31 while(<PIPE>) { 32 s/^not //; 33 print; 34 } 35 close PIPE; # avoid zombies 36 } 37 else { 38 printf STDOUT "not ok %d - open -|\n", curr_test(); 39 next_test(); 40 my $tnum = curr_test; 41 next_test(); 42 exec $Perl, '-le', "print q{not ok $tnum - again}"; 43 } 44 45 # This has to be *outside* the fork 46 next_test() for 1..2; 47 48 my $raw = "abc\nrst\rxyz\r\nfoo\n"; 49 if (open(PIPE, "-|")) { 50 $_ = join '', <PIPE>; 51 (my $raw1 = $_) =~ s/not ok \d+ - //; 52 my @r = map ord, split //, $raw; 53 my @r1 = map ord, split //, $raw1; 54 if ($raw1 eq $raw) { 55 s/^not (ok \d+ -) .*/$1 '@r1' passes through '-|'\n/s; 56 } else { 57 s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s; 58 } 59 print; 60 close PIPE; # avoid zombies 61 } 62 else { 63 printf STDOUT "not ok %d - $raw", curr_test(); 64 exec $Perl, '-e0'; # Do not run END()... 65 } 66 67 # This has to be *outside* the fork 68 next_test(); 69 70 if (open(PIPE, "|-")) { 71 printf PIPE "not ok %d - $raw", curr_test(); 72 close PIPE; # avoid zombies 73 } 74 else { 75 $_ = join '', <STDIN>; 76 (my $raw1 = $_) =~ s/not ok \d+ - //; 77 my @r = map ord, split //, $raw; 78 my @r1 = map ord, split //, $raw1; 79 if ($raw1 eq $raw) { 80 s/^not (ok \d+ -) .*/$1 '@r1' passes through '|-'\n/s; 81 } else { 82 s/^(not ok \d+ -) .*/$1 expect '@r', got '@r1'\n/s; 83 } 84 print; 85 exec $Perl, '-e0'; # Do not run END()... 86 } 87 88 # This has to be *outside* the fork 89 next_test(); 90 91 SKIP: { 92 skip "fork required", 2 unless $Config{d_fork}; 93 94 pipe(READER,WRITER) || die "Can't open pipe"; 95 96 if ($pid = fork) { 97 close WRITER; 98 while(<READER>) { 99 s/^not //; 100 y/A-Z/a-z/; 101 print; 102 } 103 close READER; # avoid zombies 104 } 105 else { 106 die "Couldn't fork" unless defined $pid; 107 close READER; 108 printf WRITER "not ok %d - pipe & fork\n", curr_test; 109 next_test; 110 111 open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT"; 112 close WRITER; 113 114 my $tnum = curr_test; 115 next_test; 116 exec $Perl, '-le', "print q{not ok $tnum - with fh dup }"; 117 } 118 119 # This has to be done *outside* the fork. 120 next_test() for 1..2; 121 } 122} 123wait; # Collect from $pid 124 125pipe(READER,WRITER) || die "Can't open pipe"; 126close READER; 127 128eval { 129 # one platform at least appears to block SIGPIPE by default (see #122112) 130 # so make sure it's unblocked. 131 # The eval wrapper should ensure this does nothing if these aren't 132 # implemented. 133 require POSIX; 134 my $mask = POSIX::SigSet->new(POSIX::SIGPIPE()); 135 my $old = POSIX::SigSet->new(); 136 POSIX::sigprocmask(POSIX::SIG_UNBLOCK(), $mask, $old); 137 note "Yes, SIGPIPE was blocked" if $old->ismember(POSIX::SIGPIPE()); 138}; 139 140$SIG{'PIPE'} = 'broken_pipe'; 141 142sub broken_pipe { 143 $SIG{'PIPE'} = 'IGNORE'; # loop preventer 144 printf "ok %d - SIGPIPE\n", curr_test; 145} 146 147printf WRITER "not ok %d - SIGPIPE\n", curr_test; 148close WRITER; 149sleep 1; 150next_test; 151pass(); 152 153SKIP: { 154 skip "no fcntl", 1 unless $Config{d_fcntl}; 155 my($r, $w); 156 pipe($r, $w) || die "pipe: $!"; 157 my $fdr = fileno($r); 158 my $fdw = fileno($w); 159 fresh_perl_is(qq( 160 print open(F, "<&=$fdr") ? 1 : 0, "\\n"; 161 print open(F, ">&=$fdw") ? 1 : 0, "\\n"; 162 ), "0\n0\n", {}, "pipe endpoints not inherited across exec"); 163} 164 165# VMS doesn't like spawning subprocesses that are still connected to 166# STDOUT. Someone should modify these tests to work with VMS. 167 168SKIP: { 169 skip "doesn't like spawning subprocesses that are still connected", 10 170 if $^O eq 'VMS'; 171 172 SKIP: { 173 # POSIX-BC doesn't report failure when closing a broken pipe 174 # that has pending output. Go figure. 175 skip "Won't report failure on broken pipe", 1 176 if $^O eq 'posix-bc'; 177 178 local $SIG{PIPE} = 'IGNORE'; 179 open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!"; 180 sleep 5; 181 if (print NIL 'foo') { 182 # If print was allowed we had better get an error on close 183 ok( !close NIL, 'close error on broken pipe' ); 184 } 185 else { 186 ok(close NIL, 'print failed on broken pipe'); 187 } 188 } 189 190 { 191 # check that errno gets forced to 0 if the piped program exited 192 # non-zero 193 open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!"; 194 $! = 1; 195 ok(!close NIL, 'close failure on non-zero piped exit'); 196 is($!, '', ' errno'); 197 isnt($?, 0, ' status'); 198 199 # Former skip block: 200 { 201 # check that status for the correct process is collected 202 my $zombie; 203 unless( $zombie = fork ) { 204 $NO_ENDING=1; 205 exit 37; 206 } 207 my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; 208 $SIG{ALRM} = sub { return }; 209 alarm(1); 210 is( close FH, '', 'close failure for... umm, something' ); 211 is( $?, 13*256, ' status' ); 212 is( $!, '', ' errno'); 213 214 my $wait = wait; 215 is( $?, 37*256, 'status correct after wait' ); 216 is( $wait, $zombie, ' wait pid' ); 217 is( $!, '', ' errno'); 218 } 219 } 220} 221 222# Test new semantics for missing command in piped open 223# 19990114 M-J. Dominus mjd@plover.com 224{ local *P; 225 no warnings 'pipe'; 226 ok( !open(P, "| "), 'missing command in piped open input' ); 227 ok( !open(P, " |"), ' output'); 228} 229 230# check that status is unaffected by implicit close 231{ 232 local(*NIL); 233 open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!"; 234 $? = 42; 235 # NIL implicitly closed here 236} 237is($?, 42, 'status unaffected by implicit close'); 238$? = 0; 239 240# check that child is reaped if the piped program can't be executed 241SKIP: { 242 skip "/no_such_process exists", 1 if -e "/no_such_process"; 243 open NIL, '/no_such_process |'; 244 close NIL; 245 246 my $child = 0; 247 eval { 248 local $SIG{ALRM} = sub { die; }; 249 alarm 2; 250 $child = wait; 251 alarm 0; 252 }; 253 254 is($child, -1, 'child reaped if piped program cannot be executed'); 255} 256 257{ 258 # [perl #122112] refcnt: fd -1 < 0 when a signal handler dies 259 # while a pipe close is waiting on a child process 260 my $prog = <<PROG; 261\$SIG{ALRM}=sub{die}; 262alarm 1; 263\$Perl = "$Perl"; 264my \$cmd = qq(\$Perl -e "sleep 3"); 265my \$pid = open my \$fh, "|\$cmd" or die "\$!\n"; 266close \$fh; 267PROG 268 my $out = fresh_perl($prog, {}); 269 cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO"); 270 # checks that that program did something rather than failing to 271 # compile 272 cmp_ok($out, '=~', qr/Died at/, "but we did get the exception from die"); 273} 274