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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
| | # Copyright (C) 2015-2021 all contributors <meta@public-inbox.org>
# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
use strict;
use warnings;
use Test::More;
use PublicInbox::Spawn qw(which spawn popen_rd);
use PublicInbox::Sigfd;
{
my $true = which('true');
ok($true, "'true' command found with which()");
}
{
my $pid = spawn(['true']);
ok($pid, 'spawned process');
is(waitpid($pid, 0), $pid, 'waitpid succeeds on spawned process');
is($?, 0, 'true exited successfully');
}
SKIP: {
my $pid = spawn(['true'], undef, { pgid => 0 });
ok($pid, 'spawned process with new pgid');
is(waitpid($pid, 0), $pid, 'waitpid succeeds on spawned process');
is($?, 0, 'true exited successfully');
pipe(my ($r, $w)) or BAIL_OUT;
$pid = eval { spawn(['true'], undef, { pgid => 1, 2 => $w }) };
close $w;
my $err = do { local $/; <$r> };
# diag "$err ($@)";
if (defined $pid) {
waitpid($pid, 0) if defined $pid;
isnt($?, 0, 'child error (pure-Perl)');
} else {
ok($@, 'exception raised');
}
}
{ # ensure waitpid(-1, 0) and SIGCHLD works in spawned process
my $script = <<'EOF';
$| = 1; # unbuffer stdout
defined(my $pid = fork) or die "fork: $!";
if ($pid == 0) { exit }
elsif ($pid > 0) {
my $waited = waitpid(-1, 0);
$waited == $pid or die "mismatched child $pid != $waited";
$? == 0 or die "child err: $>";
$SIG{CHLD} = sub { print "HI\n"; exit };
print "RDY $$\n";
select(undef, undef, undef, 0.01) while 1;
}
EOF
my $oldset = PublicInbox::DS::block_signals();
my $rd = popen_rd([$^X, '-e', $script]);
diag 'waiting for child to reap grandchild...';
chomp(my $line = readline($rd));
my ($rdy, $pid) = split(' ', $line);
is($rdy, 'RDY', 'got ready signal, waitpid(-1) works in child');
ok(kill('CHLD', $pid), 'sent SIGCHLD to child');
is(readline($rd), "HI\n", '$SIG{CHLD} works in child');
ok(close $rd, 'popen_rd close works');
PublicInbox::DS::sig_setmask($oldset);
}
{
my ($r, $w);
pipe $r, $w or die "pipe failed: $!";
my $pid = spawn(['echo', 'hello world'], undef, { 1 => fileno($w) });
close $w or die "close pipe[1] failed: $!";
is(<$r>, "hello world\n", 'read stdout of spawned from pipe');
is(waitpid($pid, 0), $pid, 'waitpid succeeds on spawned process');
is($?, 0, 'true exited successfully');
}
{
my ($r, $w);
pipe $r, $w or die "pipe failed: $!";
my $pid = spawn(['sh', '-c', 'echo $HELLO'],
{ 'HELLO' => 'world' }, { 1 => $w });
close $w or die "close pipe[1] failed: $!";
is(<$r>, "world\n", 'read stdout of spawned from pipe');
is(waitpid($pid, 0), $pid, 'waitpid succeeds on spawned process');
is($?, 0, 'sh exited successfully');
}
{
my $fh = popen_rd([qw(echo hello)]);
ok(fileno($fh) >= 0, 'tied fileno works');
my $l = <$fh>;
is($l, "hello\n", 'tied readline works');
$l = <$fh>;
ok(!$l, 'tied readline works for EOF');
}
{
my $fh = popen_rd([qw(printf foo\nbar)]);
ok(fileno($fh) >= 0, 'tied fileno works');
my $tfh = (tied *$fh)->{fh};
is($tfh->blocking(0), 1, '->blocking was true');
is($tfh->blocking, 0, '->blocking is false');
is($tfh->blocking(1), 0, '->blocking was true');
is($tfh->blocking, 1, '->blocking is true');
my @line = <$fh>;
is_deeply(\@line, [ "foo\n", 'bar' ], 'wantarray works on readline');
}
{
my $fh = popen_rd([qw(echo hello)]);
my $buf;
is(sysread($fh, $buf, 6), 6, 'sysread got 6 bytes');
is($buf, "hello\n", 'tied gets works');
is(sysread($fh, $buf, 6), 0, 'sysread got EOF');
$? = 1;
ok(close($fh), 'close succeeds');
is($?, 0, '$? set properly');
}
{
my $fh = popen_rd([qw(false)]);
ok(!close($fh), 'close fails on false');
isnt($?, 0, '$? set properly: '.$?);
}
{ # ->CLOSE vs ->DESTROY waitpid caller distinction
my @c;
my $fh = popen_rd(['true'], undef, { cb => sub { @c = caller } });
ok(close($fh), '->CLOSE fired and successful');
ok(scalar(@c), 'callback fired by ->CLOSE');
ok(grep(!m[/PublicInbox/DS\.pm\z], @c), 'callback not invoked by DS');
@c = ();
$fh = popen_rd(['true'], undef, { cb => sub { @c = caller } });
undef $fh; # ->DESTROY
ok(scalar(@c), 'callback fired by ->DESTROY');
ok(grep(!m[/PublicInbox/ProcessPipe\.pm\z], @c),
'callback not invoked by ProcessPipe');
}
{ # children don't wait on siblings
use POSIX qw(_exit);
pipe(my ($r, $w)) or BAIL_OUT $!;
my $cb = sub { warn "x=$$\n" };
my $fh = popen_rd(['cat'], undef, { 0 => $r, cb => $cb });
my $pp = tied *$fh;
my $pid = fork // BAIL_OUT $!;
local $SIG{__WARN__} = sub { _exit(1) };
if ($pid == 0) {
local $SIG{__DIE__} = sub { _exit(2) };
undef $fh;
_exit(0);
}
waitpid($pid, 0);
is($?, 0, 'forked process exited');
my @w;
local $SIG{__WARN__} = sub { push @w, @_ };
close $w;
close $fh;
is($?, 0, 'cat exited');
is_deeply(\@w, [ "x=$$\n" ], 'callback fired from owner');
}
SKIP: {
eval {
require BSD::Resource;
defined(BSD::Resource::RLIMIT_CPU())
} or skip 'BSD::Resource::RLIMIT_CPU missing', 3;
my ($r, $w);
pipe($r, $w) or die "pipe: $!";
my $cmd = ['sh', '-c', 'while true; do :; done'];
my $fd = fileno($w);
my $opt = { RLIMIT_CPU => [ 1, 1 ], RLIMIT_CORE => [ 0, 0 ], 1 => $fd };
my $pid = spawn($cmd, undef, $opt);
close $w or die "close(w): $!";
my $rset = '';
vec($rset, fileno($r), 1) = 1;
ok(select($rset, undef, undef, 5), 'child died before timeout');
is(waitpid($pid, 0), $pid, 'XCPU child process reaped');
isnt($?, 0, 'non-zero exit status');
}
done_testing();
1;
|