1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
use strict;
use warnings;
use Test::More;
use System::Command;
use File::Spec;
use Time::HiRes qw( time );
my @cmd = ( $^X, File::Spec->catfile( t => 'fail.pl' ) );
plan tests => 28;
my $status = 1;
my $delay = 2;
# catch warnings
my $expect_CHLD_warning;
$SIG{__WARN__} = sub {
my ($warning) = @_;
if ($expect_CHLD_warning) {
like(
$warning,
qr/^Child process already reaped, check for a SIGCHLD handler /,
'Warning about $SIG{CHLD}'
);
}
else {
ok( 0, "Unexpected warning: $warning" );
}
};
# just started the command
my $cmd = System::Command->new( @cmd, $status, $delay );
ok( !$cmd->is_terminated, 'child still alive' );
is( $cmd->exit, undef, 'no exit status' );
# leave it time to die
sleep $delay + 1;
ok( $cmd->is_terminated, 'child is dead now' ); # was a zombie
is( $cmd->exit, $status, 'exit status collected' );
# yes, our handles are still open
ok( $cmd->is_terminated, 'child is still dead' );
ok( $cmd->stdout->opened, 'stdout still opened' );
ok( $cmd->stderr->opened, 'stderr still opened' );
# close our handles now
$cmd->close;
ok( $cmd->is_terminated, 'child is still dead' );
ok( !$cmd->stdout->opened, 'stdout closed' );
ok( !$cmd->stderr->opened, 'stderr closed' );
# what if our user decided to reap children automatically?
diag q{$SIG{CHLD} = 'IGNORE'};
local $SIG{CHLD} = 'IGNORE';
$expect_CHLD_warning = 1;
$cmd = System::Command->new( @cmd, $status, $delay );
ok( !$cmd->is_terminated, 'child still alive' );
is( $cmd->exit, undef, 'no exit status' );
# leave it time to die
sleep $delay + 1;
ok( $cmd->is_terminated, 'child was reaped' ); # was dead and gone
is( $cmd->exit, -1, 'BOGUS exit status collected' );
# yes, our handles are still open
ok( $cmd->is_terminated, 'child is still dead' );
ok( $cmd->stdout->opened, 'stdout still opened' );
ok( $cmd->stderr->opened, 'stderr still opened' );
# close our handles now
$cmd->close;
ok( $cmd->is_terminated, 'child is still dead' );
ok( !$cmd->stdout->opened, 'stdout closed' );
ok( !$cmd->stderr->opened, 'stderr closed' );
# close first
$cmd = System::Command->new( @cmd, $status, $delay );
ok( !$cmd->is_terminated, 'child still alive' );
is( $cmd->exit, undef, 'no exit status' );
# don't leave it time, just choke it now
$cmd->close;
# See http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=666631#17
# Under load, there can be a window of time during which the child
# process is still reachable via kill(0), even though waitpid() returned
my ( $start, $pid, $attempts ) = ( time, $cmd->pid, 0 );
$attempts++ while kill 0, $pid;
diag sprintf '%d kill( 0, $pid ) attempts succeeded in %f seconds', $attempts,
time - $start
if $attempts;
ok( $cmd->is_terminated, 'child was reaped' ); # was dead and gone
is( $cmd->exit, -1, 'BOGUS exit status collected' );
ok( !$cmd->stdout->opened, 'stdout closed' );
ok( !$cmd->stderr->opened, 'stderr closed' );
# don't confuse Test::More
$? = 0;
|
