view release on metacpan or  search on metacpan

t/10-stall-timeout.t  view on Meta::CPAN

};

subtest 'a helper making steady progress is NOT killed' => sub {
  # Holds one output fd open and advances it every 0.4s for ~3.2s - longer than stall_timeout.
  # A naive timeout would kill it; the I/O-progress detector must let it finish.
  my ($u, $src, $dest) = stall_setup(
    [$^X, '-e', 'open my $f, ">", "progress.out" or die $!; for (1..8) { syswrite $f, "x" x 4096; select undef, undef, undef, 0.4 }']);
  plan skip_all => 'could not build fixture' unless $u;

  my $done = guarded(30, sub { $u->unpack($src) });
  ok($done, 'unpack() returned');
  my $out;
  find(sub { $out = $File::Find::name if $_ eq 'progress.out' }, $dest);
  ok($out, 'progressing helper ran (output present)');
  is((-s $out // 0), 8 * 4096, 'full output written - helper was never killed mid-run') if $out;
};

subtest 'a grandchild holding the pipe is reaped too' => sub {
  # sh backgrounds sleep (which inherits the pipe) then waits. Killing only the direct child
  # would leave the grandchild holding the pipe open and finish() would hang.
  my ($u, $src) = stall_setup(['/bin/sh', '-c', 'sleep 999 & wait']);
  plan skip_all => 'could not build fixture' unless $u;

  my $done = guarded(30, sub { $u->unpack($src) });
  ok($done, 'unpack() returned despite a grandchild holding the pipe');
  is(scalar(File::Unpack2::_descendant_pids($$)), 0, 'grandchild reaped, nothing left running');
};

subtest 'an archive containing a fifo does not hang and the fifo is skipped' => sub {
  my $have_tar = -x '/usr/bin/tar' || -x '/bin/tar';
  plan skip_all => 'need tar' unless $have_tar;
  my $srcdir = tempdir("FU_10f_XXXXXX", TMPDIR => 1, CLEANUP => 1);
  my $payload = "$srcdir/tree";
  mkdir $payload;
  eval { POSIX::mkfifo("$payload/a_fifo", 0600) } or plan skip_all => 'mkfifo unavailable';
  open my $reg, '>', "$payload/regular.txt" or die $!;
  print $reg "just text\n";
  close $reg;
  my $tar = "$srcdir/withfifo.tar";
  system('sh', '-c', "cd '$payload' && tar cf '$tar' .") == 0 or plan skip_all => 'could not build tar';

  my $dest = tempdir("FU_10fd_XXXXXX", TMPDIR => 1, CLEANUP => 1);
  my $u = File::Unpack2->new(destdir => $dest, verbose => 0, logfile => '/dev/null', stall_timeout => 5);
  my $done = guarded(30, sub { $u->unpack($tar) });
  ok($done, 'unpack() of a fifo-bearing archive completed without hanging');
  ok(($u->{skipped}{device_node} || 0) >= 1, 'the fifo was skipped as a special file');
};

subtest 'a helper streaming only to a pipe is NOT killed (pipe output counts as progress)' => sub {
  # It writes only to STDERR (a pipe: fdinfo pos stays 0, so the fd-position detector sees no
  # progress) every 0.3s for ~3s, then writes a marker file at the very end. With stall_timeout=2,
  # if pipe output did not count as progress it would be killed at ~2s and the marker never written.
  my ($u, $src, $dest) = stall_setup(
    [$^X, '-e', 'for (1..10) { print STDERR "x"; select undef,undef,undef,0.3 } open my $f, ">", "pipe.done" or die; print $f "ok"; close $f']);
  plan skip_all => 'could not build fixture' unless $u;

  my $done = guarded(30, sub { $u->unpack($src) });
  ok($done, 'unpack() returned');
  my $marker;
  find(sub { $marker = $File::Find::name if $_ eq 'pipe.done' }, $dest);
  ok($marker, 'a pipe-only helper ran to completion - pipe output kept it alive, not falsely killed');
};

subtest 'a reparented grandchild holding the pipe is reaped via its process group' => sub {
  # The direct child backgrounds a grandchild (which inherits the stdout pipe and the helper's
  # process group) and then exits, so the grandchild reparents to init - invisible to the ppid walk.
  # Only killing the captured process group reaps it; otherwise finish() blocks on the still-open
  # pipe forever (caught by the alarm as a failure).
  my ($u, $src) = stall_setup(['/bin/sh', '-c', 'sleep 999 & exit 0']);
  plan skip_all => 'could not build fixture' unless $u;

  my $done = guarded(30, sub { $u->unpack($src) });
  ok($done, 'unpack() returned (reparented grandchild was group-killed; finish did not hang)');
};

subtest 'stall_timeout config: default 120, env override, and 0 disables' => sub {
  my $mk = sub { File::Unpack2->new(destdir => tempdir(CLEANUP => 1), verbose => 0, logfile => '/dev/null', @_) };
  {
    local $ENV{FILE_UNPACK2_STALL_TIMEOUT};
    delete $ENV{FILE_UNPACK2_STALL_TIMEOUT};
    is($mk->()->{stall_timeout}, 120, 'default is 120s');
  }
  {
    local $ENV{FILE_UNPACK2_STALL_TIMEOUT} = 45;
    is($mk->()->{stall_timeout}, 45, 'env override honoured');
  }
  {
    local $ENV{FILE_UNPACK2_STALL_TIMEOUT} = 0;
    is($mk->()->{stall_timeout}, 0, 'env "0" disables (not silently defaulted back to 120)');
  }
  is($mk->(stall_timeout => 0)->{stall_timeout}, 0, 'explicit 0 disables');
};

subtest 'a helper does not outlive a killed parent worker (PR_SET_PDEATHSIG, when available)' => sub {
  # The optional PR_SET_PDEATHSIG safeguard: a worker (Minion job) spawns a long-running helper, then
  # the worker itself is force-killed (Minion "stop job", a deploy, a crash, the OOM killer). setpgrp
  # put the helper in its own process group, so a signal aimed at the worker never reaches it - and
  # once the worker is gone the stall watchdog is gone too. PR_SET_PDEATHSIG is what makes the kernel
  # SIGKILL the helper the instant its parent dies. Only run where syscall.ph gave us the number
  # (production perls have it); slimmed perls without it skip the safeguard AND this test.
  plan skip_all => 'stall detection needs Linux /proc'       unless -d '/proc' && -r "/proc/$$/fd";
  plan skip_all => 'no syscall.ph: PR_SET_PDEATHSIG not armed here' unless $File::Unpack2::SYS_PRCTL;

  my $pdir    = tempdir("FU_10p_XXXXXX", TMPDIR => 1, CLEANUP => 1);
  my $pidfile = "$pdir/helper.pid";                        # absolute: readable whatever the helper cwd
  my ($u, $src) = stall_setup(['/bin/sh', '-c', "echo \$\$ > '$pidfile'; exec sleep 999"]);
  plan skip_all => 'could not build fixture' unless $u;
  $u->{stall_timeout} = 60;    # long enough that the watchdog can't fire before we kill the worker

  my $worker = fork();
  defined $worker or die "fork: $!";
  if (!$worker) {
    # the "worker": spawn the helper via a normal unpack, then block so the parent can signal us.
    $u->unpack($src);
    POSIX::_exit(0);           # _exit: never run END/DESTROY (would double-flush TAP / kill helper)
  }

  # Wait (bounded) for the helper to record its pid.
  my $hpid;
  for (1 .. 100) {
    if (-s $pidfile && open(my $f, '<', $pidfile)) {
      chomp($hpid = <$f>);
      close $f;
      last if $hpid;
    }
    select undef, undef, undef, 0.1;
  }
  unless ($hpid && kill 0, $hpid) {
    kill 'KILL', $worker; waitpid $worker, 0;
    plan skip_all => 'helper did not start (fixture/timing)';
  }
  ok(1, 'helper started and is alive while the worker runs');

  # "stop job" kills the WORKER (not its process group). The helper is in its own group, so this
  # signal does not reach it - PR_SET_PDEATHSIG is what must take it down.
  kill 'KILL', $worker;
  waitpid $worker, 0;

  my $alive = 1;
  for (1 .. 100) { $alive = kill 0, $hpid; last unless $alive; select undef, undef, undef, 0.1 }
  ok(!$alive, 'helper was SIGKILLed when its parent worker died - not orphaned to spin forever');
  kill 'KILL', $hpid if $alive;    # cleanup only if the safeguard regressed
};

done_testing;