t/spawn.t

   1 #!perl -w
   2 # Copyright (C) all contributors <meta@public-inbox.org>
   3 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   4 use v5.12;
   5 use Test::More;
   6 use PublicInbox::Spawn qw(which spawn popen_rd);
   7 require PublicInbox::Sigfd;
   8 require PublicInbox::DS;
   9
  10 {
  11         my $true = which('true');
  12         ok($true, "'true' command found with which()");
  13 }
  14
  15 {
  16         my $pid = spawn(['true']);
  17         ok($pid, 'spawned process');
  18         is(waitpid($pid, 0), $pid, 'waitpid succeeds on spawned process');
  19         is($?, 0, 'true exited successfully');
  20 }
  21
  22 SKIP: {
  23         my $pid = spawn(['true'], undef, { pgid => 0 });
  24         ok($pid, 'spawned process with new pgid');
  25         is(waitpid($pid, 0), $pid, 'waitpid succeeds on spawned process');
  26         is($?, 0, 'true exited successfully');
  27         pipe(my ($r, $w)) or BAIL_OUT;
  28
  29         # Find invalid PID to try to join its process group.
  30         my $wrong_pgid = 1;
  31         for (my $i=0x7fffffff; $i >= 2; $i--) {
  32                 if (kill(0, $i) == 0) {
  33                         $wrong_pgid = $i;
  34                         last;
  35                 }
  36         }
  37
  38         # Test spawn behavior when it can't join the requested process group.
  39         $pid = eval { spawn(['true'], undef, { pgid => $wrong_pgid, 2 => $w }) };
  40         close $w;
  41         my $err = do { local $/; <$r> };
  42         if (defined $pid) {
  43                 waitpid($pid, 0);
  44                 isnt($?, 0, 'child error (pure-Perl)');
  45         } else {
  46                 ok($@, 'exception raised');
  47         }
  48 }
  49
  50 { # ensure waitpid(-1, 0) and SIGCHLD works in spawned process
  51         my $script = <<'EOF';
  52 $| = 1; # unbuffer stdout
  53 defined(my $pid = fork) or die "fork: $!";
  54 if ($pid == 0) { exit }
  55 elsif ($pid > 0) {
  56         my $waited = waitpid(-1, 0);
  57         $waited == $pid or die "mismatched child $pid != $waited";
  58         $? == 0 or die "child err: $>";
  59         $SIG{CHLD} = sub { print "HI\n"; exit };
  60         print "RDY $$\n";
  61         select(undef, undef, undef, 0.01) while 1;
  62 }
  63 EOF
  64         my $oldset = PublicInbox::DS::block_signals();
  65         my $rd = popen_rd([$^X, '-e', $script]);
  66         diag 'waiting for child to reap grandchild...';
  67         chomp(my $line = readline($rd));
  68         my ($rdy, $pid) = split(/ /, $line);
  69         is($rdy, 'RDY', 'got ready signal, waitpid(-1) works in child');
  70         ok(kill('CHLD', $pid), 'sent SIGCHLD to child');
  71         is(readline($rd), "HI\n", '$SIG{CHLD} works in child');
  72         ok(close $rd, 'popen_rd close works');
  73         PublicInbox::DS::sig_setmask($oldset);
  74 }
  75
  76 {
  77         my ($r, $w);
  78         pipe $r, $w or die "pipe failed: $!";
  79         my $pid = spawn(['echo', 'hello world'], undef, { 1 => fileno($w) });
  80         close $w or die "close pipe[1] failed: $!";
  81         is(<$r>, "hello world\n", 'read stdout of spawned from pipe');
  82         is(waitpid($pid, 0), $pid, 'waitpid succeeds on spawned process');
  83         is($?, 0, 'true exited successfully');
  84 }
  85
  86 {
  87         my ($r, $w);
  88         pipe $r, $w or die "pipe failed: $!";
  89         my $pid = spawn(['sh', '-c', 'echo $HELLO'],
  90                 { 'HELLO' => 'world' }, { 1 => $w });
  91         close $w or die "close pipe[1] failed: $!";
  92         is(<$r>, "world\n", 'read stdout of spawned from pipe');
  93         is(waitpid($pid, 0), $pid, 'waitpid succeeds on spawned process');
  94         is($?, 0, 'sh exited successfully');
  95 }
  96
  97 {
  98         my $fh = popen_rd([qw(echo hello)]);
  99         ok(fileno($fh) >= 0, 'tied fileno works');
 100         my $l = <$fh>;
 101         is($l, "hello\n", 'tied readline works');
 102         $l = <$fh>;
 103         ok(!$l, 'tied readline works for EOF');
 104 }
 105
 106 {
 107         my $fh = popen_rd([qw(printf foo\nbar)]);
 108         ok(fileno($fh) >= 0, 'tied fileno works');
 109         my $tfh = (tied *$fh)->{fh};
 110         is($tfh->blocking(0), 1, '->blocking was true');
 111         is($tfh->blocking, 0, '->blocking is false');
 112         is($tfh->blocking(1), 0, '->blocking was true');
 113         is($tfh->blocking, 1, '->blocking is true');
 114         my @line = <$fh>;
 115         is_deeply(\@line, [ "foo\n", 'bar' ], 'wantarray works on readline');
 116 }
 117
 118 {
 119         my $fh = popen_rd([qw(echo hello)]);
 120         my $buf;
 121         is(sysread($fh, $buf, 6), 6, 'sysread got 6 bytes');
 122         is($buf, "hello\n", 'tied gets works');
 123         is(sysread($fh, $buf, 6), 0, 'sysread got EOF');
 124         $? = 1;
 125         ok(close($fh), 'close succeeds');
 126         is($?, 0, '$? set properly');
 127 }
 128
 129 {
 130         my $fh = popen_rd([qw(false)]);
 131         ok(!close($fh), 'close fails on false');
 132         isnt($?, 0, '$? set properly: '.$?);
 133 }
 134
 135 {
 136         local $ENV{GIT_CONFIG} = '/path/to/this/better/not/exist';
 137         my $fh = popen_rd([qw(env)], { GIT_CONFIG => undef });
 138         ok(!grep(/^GIT_CONFIG=/, <$fh>), 'GIT_CONFIG clobbered');
 139 }
 140
 141 { # ->CLOSE vs ->DESTROY waitpid caller distinction
 142         my @c;
 143         my $fh = popen_rd(['true'], undef, { cb_arg => [sub { @c = caller }] });
 144         ok(close($fh), '->CLOSE fired and successful');
 145         ok(scalar(@c), 'callback fired by ->CLOSE');
 146         ok(grep(!m[/PublicInbox/DS\.pm\z], @c), 'callback not invoked by DS');
 147
 148         @c = ();
 149         $fh = popen_rd(['true'], undef, { cb_arg => [sub { @c = caller }] });
 150         undef $fh; # ->DESTROY
 151         ok(scalar(@c), 'callback fired by ->DESTROY');
 152         ok(grep(!m[/PublicInbox/ProcessPipe\.pm\z], @c),
 153                 'callback not invoked by ProcessPipe');
 154 }
 155
 156 { # children don't wait on siblings
 157         use POSIX qw(_exit);
 158         pipe(my ($r, $w)) or BAIL_OUT $!;
 159         my @arg;
 160         my $cb = [ sub { @arg = @_; warn "x=$$\n" }, 'hi' ];
 161         my $fh = popen_rd(['cat'], undef, { 0 => $r, cb_arg => $cb });
 162         my $pp = tied *$fh;
 163         my $pid = fork // BAIL_OUT $!;
 164         local $SIG{__WARN__} = sub { _exit(1) };
 165         if ($pid == 0) {
 166                 local $SIG{__DIE__} = sub { _exit(2) };
 167                 undef $fh;
 168                 _exit(0);
 169         }
 170         waitpid($pid, 0);
 171         is($?, 0, 'forked process exited');
 172         my @w;
 173         local $SIG{__WARN__} = sub { push @w, @_ };
 174         close $w;
 175         close $fh;
 176         is($?, 0, 'cat exited');
 177         is(scalar(@arg), 2, 'callback got args');
 178         is($arg[1], 'hi', 'passed arg');
 179         like($arg[0], qr/\A\d+\z/, 'PID');
 180         is_deeply(\@w, [ "x=$$\n" ], 'callback fired from owner');
 181 }
 182
 183 SKIP: {
 184         eval {
 185                 require BSD::Resource;
 186                 defined(BSD::Resource::RLIMIT_CPU())
 187         } or skip 'BSD::Resource::RLIMIT_CPU missing', 3;
 188         my ($r, $w);
 189         pipe($r, $w) or die "pipe: $!";
 190         my $cmd = ['sh', '-c', 'while true; do :; done'];
 191         my $fd = fileno($w);
 192         my $opt = { RLIMIT_CPU => [ 1, 1 ], RLIMIT_CORE => [ 0, 0 ], 1 => $fd };
 193         my $pid = spawn($cmd, undef, $opt);
 194         close $w or die "close(w): $!";
 195         my $rset = '';
 196         vec($rset, fileno($r), 1) = 1;
 197         ok(select($rset, undef, undef, 5), 'child died before timeout');
 198         is(waitpid($pid, 0), $pid, 'XCPU child process reaped');
 199         isnt($?, 0, 'non-zero exit status');
 200 }
 201
 202 SKIP: {
 203         require PublicInbox::SpawnPP;
 204         require File::Temp;
 205         my $tmp = File::Temp->newdir('spawnpp-XXXX', TMPDIR => 1);
 206         my $cmd = [ qw(/bin/sh -c), 'echo $HI >foo' ];
 207         my $env = [ 'HI=hihi' ];
 208         my $rlim = [];
 209         my $pgid = -1;
 210         my $pid = PublicInbox::SpawnPP::pi_fork_exec([], '/bin/sh', $cmd, $env,
 211                                                 $rlim, "$tmp", $pgid);
 212         is(waitpid($pid, 0), $pid, 'spawned process exited');
 213         is($?, 0, 'no error');
 214         open my $fh, '<', "$tmp/foo" or die "open: $!";
 215         is(readline($fh), "hihi\n", 'env+chdir worked for SpawnPP');
 216         close $fh;
 217         unlink("$tmp/foo") or die "unlink: $!";
 218         {
 219                 local $ENV{MOD_PERL} = 1;
 220                 $pid = PublicInbox::SpawnPP::pi_fork_exec([],
 221                                 '/bin/sh', $cmd, $env, $rlim, "$tmp", $pgid);
 222         }
 223         is(waitpid($pid, 0), $pid, 'spawned process exited');
 224         open $fh, '<', "$tmp/foo" or die "open: $!";
 225         is(readline($fh), "hihi\n", 'env+chdir SpawnPP under (faked) MOD_PERL');
 226 }
 227
 228 done_testing();