t/spawn.t

   1 # Copyright (C) 2015-2021 all contributors <meta@public-inbox.org>
   2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   3 use strict;
   4 use warnings;
   5 use Test::More;
   6 use PublicInbox::Spawn qw(which spawn popen_rd);
   7 use PublicInbox::Sigfd;
   8
   9 {
  10         my $true = which('true');
  11         ok($true, "'true' command found with which()");
  12 }
  13
  14 {
  15         my $pid = spawn(['true']);
  16         ok($pid, 'spawned process');
  17         is(waitpid($pid, 0), $pid, 'waitpid succeeds on spawned process');
  18         is($?, 0, 'true exited successfully');
  19 }
  20
  21 SKIP: {
  22         my $pid = spawn(['true'], undef, { pgid => 0 });
  23         ok($pid, 'spawned process with new pgid');
  24         is(waitpid($pid, 0), $pid, 'waitpid succeeds on spawned process');
  25         is($?, 0, 'true exited successfully');
  26         pipe(my ($r, $w)) or BAIL_OUT;
  27
  28         # Find invalid PID to try to join its process group.
  29         my $wrong_pgid = 1;
  30         for (my $i=0x7fffffff; $i >= 2; $i--) {
  31                 if (kill(0, $i) == 0) {
  32                         $wrong_pgid = $i;
  33                         last;
  34                 }
  35         }
  36
  37         # Test spawn behavior when it can't join the requested process group.
  38         $pid = eval { spawn(['true'], undef, { pgid => $wrong_pgid, 2 => $w }) };
  39         close $w;
  40         my $err = do { local $/; <$r> };
  41         # diag "$err ($@)";
  42         if (defined $pid) {
  43                 waitpid($pid, 0) if defined $pid;
  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 => 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 => 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 $cb = sub { warn "x=$$\n" };
 160         my $fh = popen_rd(['cat'], undef, { 0 => $r, cb => $cb });
 161         my $pp = tied *$fh;
 162         my $pid = fork // BAIL_OUT $!;
 163         local $SIG{__WARN__} = sub { _exit(1) };
 164         if ($pid == 0) {
 165                 local $SIG{__DIE__} = sub { _exit(2) };
 166                 undef $fh;
 167                 _exit(0);
 168         }
 169         waitpid($pid, 0);
 170         is($?, 0, 'forked process exited');
 171         my @w;
 172         local $SIG{__WARN__} = sub { push @w, @_ };
 173         close $w;
 174         close $fh;
 175         is($?, 0, 'cat exited');
 176         is_deeply(\@w, [ "x=$$\n" ], 'callback fired from owner');
 177 }
 178
 179 SKIP: {
 180         eval {
 181                 require BSD::Resource;
 182                 defined(BSD::Resource::RLIMIT_CPU())
 183         } or skip 'BSD::Resource::RLIMIT_CPU missing', 3;
 184         my ($r, $w);
 185         pipe($r, $w) or die "pipe: $!";
 186         my $cmd = ['sh', '-c', 'while true; do :; done'];
 187         my $fd = fileno($w);
 188         my $opt = { RLIMIT_CPU => [ 1, 1 ], RLIMIT_CORE => [ 0, 0 ], 1 => $fd };
 189         my $pid = spawn($cmd, undef, $opt);
 190         close $w or die "close(w): $!";
 191         my $rset = '';
 192         vec($rset, fileno($r), 1) = 1;
 193         ok(select($rset, undef, undef, 5), 'child died before timeout');
 194         is(waitpid($pid, 0), $pid, 'XCPU child process reaped');
 195         isnt($?, 0, 'non-zero exit status');
 196 }
 197
 198 done_testing();
 199
 200 1;