view release on metacpan or  search on metacpan

t/19-iotrace-slow-fds.t  view on Meta::CPAN

    chomp($line = <$err_fh>);
    ok($line, t." $prog: back2: $line");

    # Test #LineH: p
    # If we're quick enough, we should be able to slip a few bytes through before STDIN is closed. The bytes will remain in the kernel buffers briefly but should never actually be read. It will just be lost with the pipe is closed.
    ok(canwrite($in_fh), t." $prog: MID: STDIN is still writeable: $!");
    # Act like packets are written even though should be lost when the pipe is closed.
    ok((print $in_fh "COMPLETELY LOST PACKETS!\n"), t." $prog: line3");
    ok(!$got_piped, t." $prog: STDIN Not PIPED: $got_piped");

    # Test #LineH: close STDIN
    # Test #LineI: <STDIN> [hopefully (undef)]
    # Test #LineJ: STDOUT-BORK
    alarm 5;
    chomp($line = <$out_fh>);
    ok($line, t." $prog: back3 last out: $line");
    # Verify "#LineH" and "#LineI" worked from program side by looking for "(undef)"
    like($line, qr{undef}, t." $prog: its STDIN finished");

    # Test #LineH: close STDIN
    # Since #LineJ already ran, we know #LineH must certainly be done by now.
    alarm 5;
    ok($in_fh->opened, t." $prog: our side thinks STDIN still is open");
    ok(!$got_piped,  t." $prog: STDIN Still Not PIPED: $got_piped");
    # Attempt to write again to its STDIN to make sure it breaks this time.
    $! = 0; # Reset errno
    ok(!(print $in_fh "PIPE CRASH!\n"), t." $prog: line4: $!");
    ok($got_piped,  t." $prog: Got PIPED: $got_piped");
    $got_piped = 0;
    # Nothing left for its STDIN, so close it. Since some of the bytes sent to its STDIN weren't consumed, the close() should fail with "Broken Pipe":
    ok(!close($in_fh),  t." $prog: explicit close STDIN after broken write: $!");
    ok(!$in_fh->opened, t." $prog: STDIN not open anymore");

    # Test #LineK: p (PAUSE for one second)
    # If the STDIN test crashing happened quickly enough
    # Then STDOUT should still be open.
    alarm 5;
    ok(!canread($out_fh), t." $prog: STDOUT buffer empty but still opened: $!");

    # Test #LineK: close STDOUT
    # STDOUT should be slapped closed within 1 second
    alarm 5;
    ok(canread($out_fh, 1.9), t." $prog: EOF STDOUT buffer awoke: $!");

    # Then STDOUT should immediately hit EOF
    alarm 5;
    $line = <$out_fh>;
    ok(!$line, t." $prog: back4 eof out: ".($line || "(eof)"));

    # Nothing left for its STDOUT, so close it.
    alarm 5;
    ok(close($out_fh), t." $prog: close stdout");

    # Test #LineL: STDERR-BORK
    alarm 5;
    chomp($line = <$err_fh>);
    ok($line, t." $prog: back5: $line");
    like($line, qr{undef}, t." $prog: err finished");

    # Test #LineM: p (PAUSE for a second)
    # Quick probe to make sure prog is still alive
    alarm 5;
    my $died = waitpid(-1, WNOHANG);
    ok($died<=0, t." $prog: PID[$pid] still running: $died");

    # If the PAUSE is working, then STDERR should still be open, but empty
    alarm 5;
    $! = 0;
    ok($err_fh->opened, t." $prog: STDERR is still open: $!");
    ok(!canread($err_fh), t." $prog: STDERR buffer empty: $!");

    # Test #LineN: exit 0
    # EOF ERR: When prog completes, its STDERR should be implicitly closed.
    alarm 5;
    # Block waiting for STDERR to be closed ...
    $line = <$err_fh>;
    ok(!$line, t." $prog: back6 eof err: ".($line || "(eof)"));

    # Nothing left for its STDERR, so close it.
    alarm 5;
    ok(close($err_fh), t." $prog: close stderr");
    # Give up a little bit of time slice back to the kernel to allow enough time send me the SIGCHLD after the child's exit implicitly closed its handles.
    is(select(undef, undef, undef, 0.1), 0, t." $prog: Waited for SIGCHLD");

    # Test #LineN: exit 0
    # Once STDERR is implicitly closed, we know the prog should be done, and exit value should be 0
    alarm 5;
    $died = waitpid(-1, WNOHANG);
    is($died, $pid, t." $prog: PID[$pid] DONE[$died]");
    is($?, 0, t." $prog: normal exit: $?");
}