t/io/pipe.t

c5c4113dfcabb1eed3d4bdf7609de5170027a794nw#!./perl
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c5c4113dfcabb1eed3d4bdf7609de5170027a794nwBEGIN {
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    chdir 't' if -d 't';
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    @INC = '../lib';
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    require Config; import Config;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    require './test.pl';
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    if (!$Config{'d_fork'}) {
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw        skip_all("fork required to pipe");
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    }
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    else {
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw        plan(tests => 22);
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    }
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw}
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c5c4113dfcabb1eed3d4bdf7609de5170027a794nwmy $Perl = which_perl();
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw$| = 1;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c586600796766c83eb9485c446886fd9ed2359a9Keyur Desaiopen(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/';
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c5c4113dfcabb1eed3d4bdf7609de5170027a794nwprintf PIPE "Xk %d - open |- || exec\n", curr_test();
c5c4113dfcabb1eed3d4bdf7609de5170027a794nwnext_test();
c586600796766c83eb9485c446886fd9ed2359a9Keyur Desaiprintf PIPE "oY %d -    again\n", curr_test();
c5c4113dfcabb1eed3d4bdf7609de5170027a794nwnext_test();
c5c4113dfcabb1eed3d4bdf7609de5170027a794nwclose PIPE;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c5c4113dfcabb1eed3d4bdf7609de5170027a794nwSKIP: {
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    # Technically this should be TODO.  Someone try it if you happen to
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    # have a vmesa machine.
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    skip "Doesn't work here yet", 4 if $^O eq 'vmesa';
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    if (open(PIPE, "-|")) {
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    while(<PIPE>) {
c586600796766c83eb9485c446886fd9ed2359a9Keyur Desai        s/^not //;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw        print;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    }
c586600796766c83eb9485c446886fd9ed2359a9Keyur Desai    close PIPE;        # avoid zombies
c586600796766c83eb9485c446886fd9ed2359a9Keyur Desai    }
c586600796766c83eb9485c446886fd9ed2359a9Keyur Desai    else {
c586600796766c83eb9485c446886fd9ed2359a9Keyur Desai    printf STDOUT "not ok %d - open -|\n", curr_test();
c586600796766c83eb9485c446886fd9ed2359a9Keyur Desai        next_test();
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw        my $tnum = curr_test;
c586600796766c83eb9485c446886fd9ed2359a9Keyur Desai        next_test();
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    exec $Perl, '-le', "print q{not ok $tnum -     again}";
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    }
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    # This has to be *outside* the fork
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    next_test() for 1..2;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw    SKIP: {
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw        skip "fork required", 2 unless $Config{d_fork};
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw        pipe(READER,WRITER) || die "Can't open pipe";
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw        if ($pid = fork) {
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw            close WRITER;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw            while(<READER>) {
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw                s/^not //;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw                y/A-Z/a-z/;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw                print;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw            }
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw            close READER;     # avoid zombies
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw        }
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw        else {
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw            die "Couldn't fork" unless defined $pid;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw            close READER;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw            printf WRITER "not ok %d - pipe & fork\n", curr_test;
7a8a68f5e3efbaec1a375c2d50bd20b566631755Julian Pullen            next_test;
7a8a68f5e3efbaec1a375c2d50bd20b566631755Julian Pullen
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw            open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw            close WRITER;
c5c4113dfcabb1eed3d4bdf7609de5170027a794nw
            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;

$SIG{'PIPE'} = 'broken_pipe';

sub broken_pipe {
    $SIG{'PIPE'} = 'IGNORE';       # loop preventer
    printf "ok %d - SIGPIPE\n", curr_test;
}

printf WRITER "not ok %d - SIGPIPE\n", curr_test;
close WRITER;
sleep 1;
next_test;
pass();

# VMS doesn't like spawning subprocesses that are still connected to
# 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');
        }
    }

    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');
        }
    }
}

# 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 status is unaffected by implicit close
{
    local(*NIL);
    open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
    $? = 42;
    # NIL implicitly closed here
}
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');
}