view release on metacpan or  search on metacpan

lib/File/Unpack2.pm  view on Meta::CPAN

Using redirection operators in @redir takes precedence over the above in/out/err 
redirections. See also L<IPC::Run>. If you use the options in/out/err, you should
restrict your redirection operators to the forms '<', '0<', '1>', '2>', or '>&' due
to limitations in the precedence logic. Piping via '|' is properly recognized, 
but background execution '&' may confuse the precedence logic.

This C<run> method is completly independent of the rest of File::Unpack2. It works both
as a static function and as a method call.
It is used internally by C<unpack>, but is exported to be of use elsewhere.

Init is run after construction of redirects. Calling chdir() in init thus has no
effect on redirects with relative paths. 

Return value in scalar context is the first nonzero result code, if any. In list context 
all return values are returned.
=cut

sub run
{
  shift if ref $_[0] ne 'ARRAY';	# toss $self object handle.
  my (@cmd) = @_;
  my $opt;
     $opt = pop @cmd if ref $cmd[-1] eq 'HASH';

  my $cmdname = $cmd[0][0]; $cmdname =~ s{^.*/}{};

  # run the command with 
  # - STDIN closed, unless you specify an { in => ... }
  # - STDERR and STDOUT printed prefixed with 'E: ', 'O: ' to STDOUT, 
  #   unless you specify out =>, err =>, or out_err => ... for both.
  $opt->{in}  ||= \undef;
  $opt->{out} ||= $opt->{out_err};
  $opt->{err} ||= $opt->{out_err};
  $opt->{out} ||= sub { print "O: ($cmdname) @_\n"; };
  $opt->{err} ||= sub { print "E: ($cmdname) @_\n"; };

  # When a watchdog is active: (1) treat ANY helper output as progress - pipes/sockets have no fd
  # "pos" for the stall detector to see, so a helper streaming to a pipe would otherwise look
  # stalled and be killed; (2) run each helper in its own process group so _kill_family can reap the
  # whole family (including grandchildren) instead of leaving a pipe-holder that hangs finish().
  if ($opt->{stall_timeout} or $opt->{helper_timeout})
    {
      for my $ch (qw(out err))
        {
	  next unless ref $opt->{$ch} eq 'CODE';    # leave file/handle redirects (e.g. '/dev/null') alone
	  my $orig = $opt->{$ch};
	  $opt->{$ch} = sub { $opt->{last_progress} = time; $orig->(@_) };
	}
      $opt->{init} ||= sub {
        # Optional safeguard (armed only where syscall.ph gave us the prctl number - see $SYS_PRCTL):
        # PR_SET_PDEATHSIG(SIGKILL) makes the kernel kill this helper the instant its parent worker
        # dies, so a stuck helper (e.g. a malicious cyclic-hardlink tar spinning on stat()/linkat())
        # is not orphaned to ppid==1 to spin forever when the worker is force-stopped mid-unpack
        # (Minion "stop job", a hard restart, a crash) - the case the stall watchdog can't cover
        # because it dies with the worker. PR_SET_PDEATHSIG is 1 on every Linux arch. Where the
        # syscall number was unresolved this is skipped; then that narrow orphan window remains and
        # such orphans must be cleaned up out of band (or the worker stopped via systemd
        # KillMode=control-group, which reaps the whole cgroup).
        eval { syscall($SYS_PRCTL, 1, POSIX::SIGKILL()) if $SYS_PRCTL; 1 };
        # ... and put each helper in its own process group so _kill_family can reap the whole family
        # (grandchildren included) while we are alive.
        setpgrp(0, 0);    # builtin; POSIX::setpgrp is unimplemented on modern perl
      };
    }

  my $has_i_redir = 0;
  my $has_o_redir = 0;
  my $has_e_redir = 0;

  ## The ugly truth is, there might be multiple commands with pipes.
  ## We need to provide all of them with the proper redirects.
  ## A command that pipes somewhere else, has_o_redir outbound through the pipe.
  ## A command that is piped into, has_i_redir inbound from the pipe.
  my @run = ();


  for my $c (@cmd)
    {
      if (ref $c)
        {
          push @run, $c;

          # put init early, so that it is run, before any IO redirects access relative paths.
          push @run, init => $opt->{init} if $opt->{init};
          next;		# don't look into argvs, but
	}
      # look only into redirection operators
      $has_i_redir++ if $c =~ m{^0?<};
      $has_o_redir++ if $c =~ m{^1?>};
      $has_e_redir++ if $c =~ m{^(?:2>|>&$)};
      if ($c eq '|')
        {
          push @run, '0<', $opt->{in} unless $has_i_redir;
	  $has_i_redir = 'piped';
          push @run, "2>", $opt->{err} unless $has_e_redir;
	  $has_e_redir = $has_o_redir = 0;
	}
      push @run, $c;	# $1 if $c =~ m{^(.*)$}s;	# brute force untaint
    }

  push @run, '0<', $opt->{in}  unless $has_i_redir;
  push @run, "1>", $opt->{out} unless $has_o_redir;
  push @run, "2>", $opt->{err} unless $has_e_redir;

  my $t;
     $t = IPC::Run::timer($opt->{every}-0.6) if $opt->{every};
  push @run, $t if $t;

  $run[0][0] = $1 if $run[0][0] =~ m{^(.*)$}s;
  push @run, debug => $opt->{debug} if $opt->{debug};
  my $h = eval { IPC::Run::start @run; };
  return wantarray ? (undef, $@) : undef unless $h;

  # Each helper stage put itself in its own process group (setpgrp in init), so its PID is its
  # pgid. Capture them now: killing these groups later reaps grandchildren even after a stage exits
  # and its children reparent to init (they keep the group). Guarded - falls back to the live
  # descendant walk if IPC::Run's internals ever change.
  my @pgids;
  if ($opt->{stall_timeout} or $opt->{helper_timeout})
    {
      @pgids = eval { grep { $_ and $_ > 1 } map { $_->{PID} } @{$h->{KIDS} || []} };