X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fio%2Fpipe.t;h=c32f3b1046cfa271e2985899040842bfad73d6f6;hb=2d862febb32638bf1f7663134644cf7e37f284ad;hp=d89bad8c4f849e0dbcfb8a159c2d054557f78b2c;hpb=e5e1b98b7a55f8984e74bbc5d6484d24ab6375fa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/io/pipe.t b/t/io/pipe.t index d89bad8..c32f3b1 100755 --- a/t/io/pipe.t +++ b/t/io/pipe.t @@ -1,67 +1,88 @@ #!./perl -# $RCSfile: pipe.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:31 $ - BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require Config; import Config; - unless ($Config{'d_fork'}) { - print "1..0\n"; - exit 0; + require './test.pl'; + + if (!$Config{'d_fork'}) { + skip_all("fork required to pipe"); + } + else { + plan(tests => 22); } } +my $Perl = which_perl(); + + $| = 1; -print "1..12\n"; -# External program 'tr' assumed. -open(PIPE, "|-") || (exec 'tr', 'YX', 'ko'); -print PIPE "Xk 1\n"; -print PIPE "oY 2\n"; +open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/'; + +printf PIPE "Xk %d - open |- || exec\n", curr_test(); +next_test(); +printf PIPE "oY %d - again\n", curr_test(); +next_test(); close PIPE; -if ($^O eq 'vmesa') { - # Doesn't work, yet. - print "ok 3\n"; - print "ok 4\n"; - print "ok 5\n"; - print "ok 6\n"; -} else { +SKIP: { + # Technically this should be TODO. Someone try it if you happen to + # have a vmesa machine. + skip "Doesn't work here yet", 4 if $^O eq 'vmesa'; + if (open(PIPE, "-|")) { while() { s/^not //; print; } - close PIPE; # avoid zombies which disrupt test 12 + close PIPE; # avoid zombies } else { - # External program 'echo' assumed. - print STDOUT "not ok 3\n"; - exec 'echo', 'not ok 4'; + printf STDOUT "not ok %d - open -|\n", curr_test(); + next_test(); + my $tnum = curr_test; + next_test(); + exec $Perl, '-le', "print q{not ok $tnum - again}"; } - pipe(READER,WRITER) || die "Can't open pipe"; - - if ($pid = fork) { - close WRITER; - while() { - s/^not //; - y/A-Z/a-z/; - print; - } - close READER; # avoid zombies which disrupt test 12 - } - else { - die "Couldn't fork" unless defined $pid; - close READER; - print WRITER "not ok 5\n"; - open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT"; - close WRITER; - # External program 'echo' assumed. - exec 'echo', 'not ok 6'; + # This has to be *outside* the fork + next_test() for 1..2; + + SKIP: { + skip "fork required", 2 unless $Config{d_fork}; + + pipe(READER,WRITER) || die "Can't open pipe"; + + if ($pid = fork) { + close WRITER; + while() { + s/^not //; + y/A-Z/a-z/; + print; + } + close READER; # avoid zombies + } + else { + die "Couldn't fork" unless defined $pid; + close READER; + printf WRITER "not ok %d - pipe & fork\n", curr_test; + next_test; + + open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT"; + close WRITER; + + my $tnum = curr_test; + next_test; + exec $Perl, '-le', "print q{not ok $tnum - with fh dup }"; + } + + # This has to be done *outside* the fork. + next_test() for 1..2; } -} +} +wait; # Collect from $pid pipe(READER,WRITER) || die "Can't open pipe"; close READER; @@ -70,85 +91,108 @@ $SIG{'PIPE'} = 'broken_pipe'; sub broken_pipe { $SIG{'PIPE'} = 'IGNORE'; # loop preventer - print "ok 7\n"; + printf "ok %d - SIGPIPE\n", curr_test; } -print WRITER "not ok 7\n"; +printf WRITER "not ok %d - SIGPIPE\n", curr_test; close WRITER; sleep 1; -print "ok 8\n"; +next_test; +pass(); # VMS doesn't like spawning subprocesses that are still connected to -# STDOUT. Someone should modify tests #9 to #12 to work with VMS. - -if ($^O eq 'VMS') { - print "ok 9\n"; - print "ok 10\n"; - print "ok 11\n"; - print "ok 12\n"; - exit; -} - -if ($Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' || $^O eq 'posix-bc') { - # Sfio doesn't report failure when closing a broken pipe - # that has pending output. Go figure. MachTen doesn't either, - # but won't write to broken pipes, so nothing's pending at close. - # BeOS will not write to broken pipes, either. - # Nor does POSIX-BC. - print "ok 9\n"; -} -else { - local $SIG{PIPE} = 'IGNORE'; - open NIL, '|true' or die "open failed: $!"; - sleep 2; - print NIL 'foo' or die "print failed: $!"; - if (close NIL) { - print "not ok 9\n"; +# STDOUT. Someone should modify these tests to work with VMS. + +SKIP: { + skip "doesn't like spawning subprocesses that are still connected", 10 + if $^O eq 'VMS'; + + SKIP: { + # Sfio doesn't report failure when closing a broken pipe + # that has pending output. Go figure. MachTen doesn't either, + # but won't write to broken pipes, so nothing's pending at close. + # BeOS will not write to broken pipes, either. + # Nor does POSIX-BC. + skip "Won't report failure on broken pipe", 1 + if $Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' || + $^O eq 'posix-bc'; + + local $SIG{PIPE} = 'IGNORE'; + open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!"; + sleep 5; + if (print NIL 'foo') { + # If print was allowed we had better get an error on close + ok( !close NIL, 'close error on broken pipe' ); + } + else { + ok(close NIL, 'print failed on broken pipe'); + } } - else { - print "ok 9\n"; + + SKIP: { + skip "Don't work yet", 9 if $^O eq 'vmesa'; + + # check that errno gets forced to 0 if the piped program exited + # non-zero + open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!"; + $! = 1; + ok(!close NIL, 'close failure on non-zero piped exit'); + is($!, '', ' errno'); + isnt($?, 0, ' status'); + + SKIP: { + skip "Don't work yet", 6 if $^O eq 'mpeix'; + + # check that status for the correct process is collected + my $zombie; + unless( $zombie = fork ) { + $NO_ENDING=1; + exit 37; + } + my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; + $SIG{ALRM} = sub { return }; + alarm(1); + is( close FH, '', 'close failure for... umm, something' ); + is( $?, 13*256, ' status' ); + is( $!, '', ' errno'); + + my $wait = wait; + is( $?, 37*256, 'status correct after wait' ); + is( $wait, $zombie, ' wait pid' ); + is( $!, '', ' errno'); + } } } -if ($^O eq 'vmesa') { - # These don't work, yet. - print "ok 10\n"; - print "ok 11\n"; - print "ok 12\n"; - exit; +# Test new semantics for missing command in piped open +# 19990114 M-J. Dominus mjd@plover.com +{ local *P; + ok( !open(P, "| "), 'missing command in piped open input' ); + ok( !open(P, " |"), ' output'); } -# check that errno gets forced to 0 if the piped program exited non-zero -open NIL, '|exit 23;' or die "fork failed: $!"; -$! = 1; -if (close NIL) { - print "not ok 10\n# successful close\n"; -} -elsif ($! != 0) { - print "not ok 10\n# errno $!\n"; -} -elsif ($? == 0) { - print "not ok 10\n# status 0\n"; +# check that status is unaffected by implicit close +{ + local(*NIL); + open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!"; + $? = 42; + # NIL implicitly closed here } -else { - print "ok 10\n"; -} - -# check that status for the correct process is collected -wait; # Collect from $pid -my $zombie = fork or exit 37; -my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n"; -$SIG{ALRM} = sub { return }; -alarm(1); -my $close = close FH; -if ($? == 13*256 && ! length $close && ! $!) { - print "ok 11\n"; -} else { - print "not ok 11\n# close $close\$?=$? \$!=", $!+0, ":$!\n"; -}; -my $wait = wait; -if ($? == 37*256 && $wait == $zombie && ! $!) { - print "ok 12\n"; -} else { - print "not ok 12\n# pid=$wait first=$pid pipe=$pipe zombie=$zombie me=$$ \$?=$? \$!=", $!+0, ":$!\n"; +is($?, 42, 'status unaffected by implicit close'); +$? = 0; + +# check that child is reaped if the piped program can't be executed +{ + open NIL, '/no_such_process |'; + close NIL; + + my $child = 0; + eval { + local $SIG{ALRM} = sub { die; }; + alarm 2; + $child = wait; + alarm 0; + }; + + is($child, -1, 'child reaped if piped program cannot be executed'); }