# SPDX-License-Identifier: GPL-2.0-or-later

package Amavis::ProcControl;
use strict;
use re 'taint';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&exit_status_str &proc_status_ok &kill_proc &cloexec
                  &run_command &run_command_consumer &run_as_subprocess
                  &collect_results &collect_results_structured);
}
use subs @EXPORT_OK;

use POSIX qw(:sys_wait_h WIFEXITED WIFSIGNALED WIFSTOPPED WEXITSTATUS
             WTERMSIG WSTOPSIG);
use Errno qw(ENOENT EACCES EAGAIN ESRCH);
use IO::File ();
use Time::HiRes ();
# use Fcntl qw(F_GETFD F_SETFD FD_CLOEXEC);  # used in cloexec, if enabled

use Amavis::Conf qw(:platform c cr ca);
use Amavis::Log qw(open_log close_log log_fd);
use Amavis::Util qw(ll do_log do_log_safe prolong_timer untaint
                   flush_captured_log reposition_captured_log_to_end);

# map process termination status number to an informative string, and
# append optional message (dual-valued errno or a string or a number),
# returning the resulting string
#
sub exit_status_str($;$) {
  my($stat,$errno) = @_; my $str;
  if (!defined($stat)) {
    $str = '(no status)';
  } elsif (WIFEXITED($stat)) {
    $str = sprintf('exit %d', WEXITSTATUS($stat));
  } elsif (WIFSTOPPED($stat)) {
    $str = sprintf('stopped, signal %d', WSTOPSIG($stat));
  } else {  # WIFSIGNALED($stat)
    my $sig = WTERMSIG($stat);
    $str = sprintf('%s, signal %d (%04x)',
             $sig == 1 ? 'HANGUP' : $sig == 2 ? 'INTERRUPTED' :
             $sig == 6 ? 'ABORTED' : $sig == 9 ? 'KILLED' :
             $sig == 15 ? 'TERMINATED' : 'DIED',
             $sig, $stat);
  }
  if (defined $errno) {  # deal with dual-valued and plain variables
    $str .= ', '.$errno  if (0+$errno) != 0 || ($errno ne '' && $errno ne '0');
  }
  $str;
}

# check errno to be 0 and a process exit status to be in the list of success
# status codes, returning true if both are ok, and false otherwise
#
sub proc_status_ok($;$@) {
  my($exit_status,$errno,@success) = @_;
  my $ok = 0;
  if ((!defined $errno || $errno == 0) && WIFEXITED($exit_status)) {
    my $j = WEXITSTATUS($exit_status);
    if (!@success) { $ok = $j==0 }  # empty list implies only status 0 is good
    elsif (grep($_==$j, @success)) { $ok = 1 }
  }
  $ok;
}

# kill a process, typically a spawned external decoder or checker
#
sub kill_proc($;$$$$) {
  my($pid,$what,$timeout,$proc_fh,$reason) = @_;
  $pid >= 0  or die "Shouldn't be killing process groups: [$pid]";
  $pid != 1  or die "Shouldn't be killing process 'init': [$pid]";
  $what   = defined $what   ? " running $what"     : '';
  $reason = defined $reason ? " (reason: $reason)" : '';
  #
  # the following order is a must: SIGTERM first, _then_ close a pipe;
  # otherwise the following can happen: closing a pipe first (explicitly or
  # implicitly by undefining $proc_fh) blocks us so we never send SIGTERM
  # until the external process dies of natural death; on the other hand,
  # not closing the pipe after SIGTERM does not necessarily let the process
  # notice SIGTERM, so SIGKILL is always needed to stop it, which is not nice
  #
  my $n = kill(0,$pid);  # does the process really exist?
  if ($n == 0 && $! != ESRCH) {
    die sprintf("Can't send SIG 0 to process [%s]%s: %s", $pid,$what,$!);
  } elsif ($n == 0) {
    do_log(2, 'no need to kill process [%s]%s, already gone', $pid,$what);
  } else {
    do_log(-1,'terminating process [%s]%s%s', $pid,$what,$reason);
    kill('TERM',$pid) or $! == ESRCH  # be gentle on the first attempt
      or die sprintf("Can't send SIGTERM to process [%s]%s: %s",$pid,$what,$!);
  }
  # close the pipe if still open, ignoring status
  $proc_fh->close  if defined $proc_fh;
  my $child_stat = defined $pid && waitpid($pid,WNOHANG) > 0 ? $? : undef;
  $n = kill(0,$pid);  # is the process still there?
  if ($n > 0 && defined($timeout) && $timeout > 0) {
    sleep($timeout); $n = kill(0,$pid);  # wait a little and recheck
  }
  if ($n == 0 && $! != ESRCH) {
    die sprintf("Can't send SIG 0 to process [%s]%s: %s", $pid,$what,$!);
  } elsif ($n > 0) {  # the process is still there, try a stronger signal
    do_log(-1,'process [%s]%s is still alive, using a bigger hammer (SIGKILL)',
              $pid,$what);
    kill('KILL',$pid) or $! == ESRCH
      or die sprintf("Can't send SIGKILL to process [%s]%s: %s",$pid,$what,$!);
  }
}

sub cloexec($;$$) { undef }
# sub cloexec($;$$) {  # supposedly not needed for Perl >= 5.6.0
#   my($fh,$newsetting,$name) = @_; my $flags;
#   $flags = fcntl($fh, F_GETFD, 0)
#     or die "Can't get close-on-exec flag for file handle $fh $name: $!";
#   $flags = 0 + $flags;  # turn into numeric, avoid: "0 but true"
#   if (defined $newsetting) {  # change requested?
#     my $newflags = $newsetting ? ($flags|FD_CLOEXEC) : ($flags&~FD_CLOEXEC);
#     if ($flags != $newflags) {
#       do_log(4,"cloexec: turning %s flag FD_CLOEXEC for file handle %s %s",
#              $newsetting ? "ON" : "OFF", $fh, $name);
#       fcntl($fh, F_SETFD, $newflags)
#         or die "Can't set FD_CLOEXEC for file handle $fh $name: $!";
#     }
#   }
#   ($flags & FD_CLOEXEC) ? 1 : 0;  # returns old setting
# }

# POSIX::open a file or dup an existing fd (Perl open syntax), with a
# requirement that it gets opened on a prescribed file descriptor $fd_target.
# Returns a file descriptor number (not a Perl file handle, there is no
# associated file handle). Usually called from a forked process prior to exec.
#
sub open_on_specific_fd($$$$) {
  my($fd_target,$fname,$flags,$mode) = @_;
  my $fd_got;  # fd directly given as argument, or obtained from POSIX::open
  my $logging_safe = 0;
  if (ll(5)) {
    # crude attempt to prevent a forked process from writing log records
    # to its parent process on STDOUT or STDERR
    my $log_fd = log_fd();
    $logging_safe = 1  if !defined($log_fd) || $log_fd > 2;
  }
  local($1);
  if ($fname =~ /^&=?(\d+)\z/) { $fd_got = $1 }  # fd directly specified
  my $flags_displayed = $flags == &POSIX::O_RDONLY ? '<'
                      : $flags == &POSIX::O_WRONLY ? '>' : '('.$flags.')';
  if (!defined($fd_got) || $fd_got != $fd_target) {
    # close whatever is on a target descriptor but don't shoot self in the foot
    # with Net::Server <= 0.90 fd0 was main::stdin, but no longer is in 0.91
    do_log_safe(5, "open_on_specific_fd: target fd%s closing, to become %s %s",
                $fd_target, $flags_displayed, $fname)
                if $logging_safe && ll(5);
    # it pays off to close explicitly, with some luck open will get a target fd
    POSIX::close($fd_target);  # ignore error; we may have just closed a log
  }
  if (!defined($fd_got)) {  # a file name was given, not a descriptor
    $fd_got = POSIX::open($fname,$flags,$mode);
    defined $fd_got or die "Can't open $fname ($flags,$mode): $!";
    $fd_got = 0 + $fd_got;  # turn into numeric, avoid: "0 but true"
  }
  if ($fd_got != $fd_target) {  # dup, ensuring we get a requested descriptor
    # we may have been left without a log file descriptor, must not die
    do_log_safe(5, "open_on_specific_fd: target fd%s dup2 from fd%s %s %s",
                $fd_target, $fd_got, $flags_displayed, $fname)
                if $logging_safe && ll(5);
    # POSIX mandates we got the lowest fd available (but some kernels have
    # bugs), let's be explicit that we require a specified file descriptor
    defined POSIX::dup2($fd_got,$fd_target)
      or die "Can't dup2 from $fd_got to $fd_target: $!";
    if ($fd_got > 2) {  # let's get rid of the original fd, unless 0,1,2
      my $err; defined POSIX::close($fd_got) or $err = $!;
      $err = defined $err ? ": $err" : '';
      # we may have been left without a log file descriptor, don't die
      do_log_safe(5, "open_on_specific_fd: source fd%s closed%s",
                  $fd_got,$err)  if $logging_safe && ll(5);
    }
  }
  $fd_got;
}

sub release_parent_resources() {
  $Amavis::sql_dataset_conn_lookups->dbh_inactive(1)
    if $Amavis::sql_dataset_conn_lookups;
  $Amavis::sql_dataset_conn_storage->dbh_inactive(1)
    if $Amavis::sql_dataset_conn_storage;
  $Amavis::zmq_obj->inactivate
    if $Amavis::zmq_obj;
# undef $Amavis::sql_dataset_conn_lookups;
# undef $Amavis::sql_dataset_conn_storage;
# undef $Amavis::snmp_db;
# undef $Amavis::db_env;
}

# Run specified command as a subprocess (like qx operator, but more careful
# with error reporting and cancels :utf8 mode). If $stderr_to is undef or
# an empty string it is converted to '&1', merging stderr to stdout on fd1.
# Return a file handle open for reading from the subprocess.
#
sub run_command($$@) {
  my($stdin_from, $stderr_to, $cmd, @args) = @_;
  my $cmd_text = join(' ', $cmd, @args);
  $stdin_from = '/dev/null'  if !defined $stdin_from || $stdin_from eq '';
  $stderr_to = '&1'  if !defined $stderr_to || $stderr_to eq '';  # to stdout
  my $msg = join(' ', $cmd, @args, "<$stdin_from", "2>$stderr_to");
# $^F == 2  or do_log(-1,"run_command: SYSTEM_FD_MAX not 2: %d", $^F);
  my $proc_fh      = IO::File->new;  # parent reading side of the pipe
  my $child_out_fh = IO::File->new;  # child writing side of the pipe
  pipe($proc_fh,$child_out_fh)
    or die "run_command: Can't create a pipe: $!";
  flush_captured_log();
  my $pid;
  eval {
    # Avoid using open('-|') which is just too damn smart: possibly waiting
    # indefinitely when resources are tight, and not catching fork errors as
    # expected but just bailing out of eval; make a pipe explicitly and fork.
    # Note that fork(2) returns ENOMEM on lack of swap space, and EAGAIN when
    # process limit is reached; we want it to fail in both cases and not obey
    # the EAGAIN and keep retrying, as perl open() does.
    $pid = fork(); 1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die "run_command (forking): $eval_stat";
  };
  defined($pid) or die "run_command: can't fork: $!";
  if (!$pid) {  # child
    alarm(0); my $interrupt = '';
    my $h1 = sub { $interrupt = $_[0] };
    my $h2 = sub { die "Received signal ".$_[0] };
    @SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7;
    my $err;
    eval {  # die must be caught, otherwise we end up with two running daemons
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
#     use Devel::Symdump ();
#     my $dumpobj = Devel::Symdump->rnew;
#     for my $k ($dumpobj->ios) {
#       no strict 'refs';  my $fn = fileno($k);
#       if (!defined($fn)) { do_log(2, "not open %s", $k) }
#       elsif ($fn == 1 || $fn == 2) { do_log(2, "KEEP %s, fileno=%s",$k,$fn) }
#       else { $! = 0;
#         close(*{$k}{IO}) and do_log(2, "DID CLOSE %s (fileno=%s)", $k,$fn);
#       }
#     }
      eval { release_parent_resources() };
      $proc_fh->close or die "Child can't close parent side of a pipe: $!";
      if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
      # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
      my $opt_rdonly = untaint(&POSIX::O_RDONLY);
      my $opt_wronly = untaint(&POSIX::O_WRONLY | &POSIX::O_CREAT);
      open_on_specific_fd(0, $stdin_from, $opt_rdonly, 0);
      open_on_specific_fd(1, '&='.fileno($child_out_fh), $opt_wronly, 0);
      open_on_specific_fd(2, $stderr_to, $opt_wronly, 0);
    # eval { close_log() };  # may have been closed by open_on_specific_fd
      # BEWARE of Perl older that 5.6.0: sockets and pipes were not FD_CLOEXEC
      exec {$cmd} ($cmd,@args);
      die "run_command: failed to exec $cmd_text: $!";
      0;  # paranoia
    } or do {
      $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
    };
    eval {
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
      open_log();  # oops, exec failed, we will need logging after all...
      # we're in trouble if stderr was attached to a terminal, but no longer is
      do_log_safe(-1,"run_command: child process [%s]: %s", $$,$err);
    } or 1;  # ignore failures, make perlcritic happy
    { # no warnings;
      POSIX::_exit(3);  # SIGQUIT, avoid END and destructor processing
    # POSIX::_exit(6);  # SIGABRT, avoid END and destructor processing
      kill('KILL',$$); exit 1;   # still kicking? die!
    }
  }
  # parent
  ll(5) && do_log(5,"run_command: [%s] %s", $pid,$msg);
  $child_out_fh->close
    or die "Parent failed to close child side of the pipe: $!";
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  ($proc_fh, $pid);  # return pipe file handle to the subprocess and its PID
}

# Run a specified command as a subprocess. Return a file handle open for
# WRITING to the subprocess, utf8 mode canceled and autoflush turned OFF !
# If $stderr_to is undef or is an empty string it is converted to '&1',
# merging stderr to stdout on fd1.
#
sub run_command_consumer($$@) {
  my($stdout_to, $stderr_to, $cmd, @args) = @_;
  my $cmd_text = join(' ', $cmd, @args);
  $stdout_to = '/dev/null'  if !defined $stdout_to || $stdout_to eq '';
  $stderr_to = '&1'  if !defined $stderr_to || $stderr_to eq '';  # to stdout
  my $msg = join(' ', $cmd, @args, ">$stdout_to", "2>$stderr_to");
# $^F == 2  or do_log(-1,"run_command_consumer: SYSTEM_FD_MAX not 2: %d", $^F);
  my $proc_fh     = IO::File->new;  # parent writing side of the pipe
  my $child_in_fh = IO::File->new;  # child reading side of the pipe
  pipe($child_in_fh,$proc_fh)
    or die "run_command_consumer: Can't create a pipe: $!";
  flush_captured_log();
  my $pid;
  eval {
    # Avoid using open('|-') which is just too damn smart: possibly waiting
    # indefinitely when resources are tight, and not catching fork errors as
    # expected but just bailing out of eval; make a pipe explicitly and fork.
    # Note that fork(2) returns ENOMEM on lack of swap space, and EAGAIN when
    # process limit is reached; we want it to fail in both cases and not obey
    # the EAGAIN and keep retrying, as perl open() does.
    $pid = fork(); 1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die "run_command_consumer (fork): $eval_stat";
  };
  defined($pid) or die "run_command_consumer: can't fork: $!";
  if (!$pid) {  # child
    alarm(0); my $interrupt = '';
    my $h1 = sub { $interrupt = $_[0] };
    my $h2 = sub { die "Received signal ".$_[0] };
    @SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7;
    my $err;
    eval {  # die must be caught, otherwise we end up with two running daemons
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      eval { release_parent_resources() };
      $proc_fh->close or die "Child can't close parent side of a pipe: $!";
      if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
      # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
      my $opt_rdonly = untaint(&POSIX::O_RDONLY);
      my $opt_wronly = untaint(&POSIX::O_WRONLY | &POSIX::O_CREAT);
      open_on_specific_fd(0, '&='.fileno($child_in_fh), $opt_rdonly, 0);
      open_on_specific_fd(1, $stdout_to, $opt_wronly, 0);
      open_on_specific_fd(2, $stderr_to, $opt_wronly, 0);
    # eval { close_log() };  # may have been closed by open_on_specific_fd
      # BEWARE of Perl older that 5.6.0: sockets and pipes were not FD_CLOEXEC
      exec {$cmd} ($cmd,@args);
      die "run_command_consumer: failed to exec $cmd_text: $!";
      0;  # paranoia
    } or do {
      $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
    };
    eval {
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
      open_log();  # oops, exec failed, we will need logging after all...
      # we're in trouble if stderr was attached to a terminal, but no longer is
      do_log_safe(-1,"run_command_consumer: child process [%s]: %s", $$,$err);
    } or 1;  # ignore failures, make perlcritic happy
    { # no warnings;
      POSIX::_exit(3);  # SIGQUIT, avoid END and destructor processing
    # POSIX::_exit(6);  # SIGABRT, avoid END and destructor processing
      kill('KILL',$$); exit 1;   # still kicking? die!
    }
  }
  # parent
  ll(5) && do_log(5,"run_command_consumer: [%s] %s", $pid,$msg);
  $child_in_fh->close
    or die "Parent failed to close child side of the pipe: $!";
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  $proc_fh->autoflush(0);  # turn it off here, must call ->flush when needed
  ($proc_fh, $pid);  # return pipe file handle to the subprocess and its PID
}

# run a specified subroutine with given arguments as a (forked) subprocess,
# collecting results (if any) over a pipe from a subprocess and propagating
# them back to a caller; (useful to prevent a potential process crash from
# bringing down the main process, and allows cleaner timeout aborts)
#
sub run_as_subprocess($@) {
  my($code,@args) = @_;
  alarm(0);  # stop the timer
  my $proc_fh      = IO::File->new;  # parent reading side of the pipe
  my $child_out_fh = IO::File->new;  # child writing side of the pipe
  pipe($proc_fh,$child_out_fh)
    or die "run_as_subprocess: Can't create a pipe: $!";
  flush_captured_log();
  my $pid;
  eval {
    # Avoid using open('-|') which is just too damn smart: possibly waiting
    # indefinitely when resources are tight, and not catching fork errors as
    # expected but just bailing out of eval; make a pipe explicitly and fork.
    # Note that fork(2) returns ENOMEM on lack of swap space, and EAGAIN when
    # process limit is reached; we want it to fail in both cases and not obey
    # the EAGAIN and keep retrying, as perl open() does.
    $pid = fork(); 1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die "run_as_subprocess (forking): $eval_stat";
  };
  defined($pid) or die "run_as_subprocess: can't fork: $!";
  if (!$pid) {  # child
    # timeouts will be also be handled by a parent process
    my $t0 = Time::HiRes::time; my(@result); my $interrupt = '';
    my $h1 = sub { $interrupt = $_[0] };
    my $h2 = sub { die "Received signal ".$_[0] };
    @SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7;
    $SIG{PIPE} = 'IGNORE';  # don't signal on a write to a widowed pipe
    my $myownpid = $$;  # fetching $$ is a syscall
    $0 = 'sub-' . c('myprogram_name');  # let it show in ps(1)
    my $eval_stat;
    eval {  # die must be caught, otherwise we end up with two running daemons
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      eval { release_parent_resources() };
      $proc_fh->close or die "Child can't close parent side of a pipe: $!";
      if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
      prolong_timer("child[$myownpid]");  # restart the timer
      binmode($child_out_fh) or die "Can't set pipe to binmode: $!";
      # we don't really need STDOUT here, but just in case the supplied code
      # happens to write there, let's make STDOUT a dup of a pipe
      close STDOUT;  # ignoring status
      # prefer dup(2) here instead of fdopen, with some luck this gives us fd1
      open(STDOUT, '>&'.fileno($child_out_fh))
        or die "Child can't dup pipe to STDOUT: $!";
      binmode(STDOUT) or die "Can't set STDOUT to binmode: $!";
      #*** should re-establish ZMQ sockets here without clobbering parent
      ll(5) && do_log(5,'[%s] run_as_subprocess: running as child, '.
                        'stdin=%s, stdout=%s, pipe=%s',  $myownpid,
                        fileno(STDIN), fileno(STDOUT), fileno($child_out_fh));
      @result = &$code(@args);  # invoke a caller-specified subroutine
      1;
    } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
    my $dt = Time::HiRes::time - $t0;
    eval {  # must not use die in forked process, or we end up with two daemons
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
      my $status; my $ll = 3;
      if (defined $eval_stat) {  # failure
        chomp $eval_stat; $ll = -2;
        $status = sprintf("STATUS: FAILURE %s", $eval_stat);
      } else {  # success
        $status = sprintf("STATUS: SUCCESS, %d results", scalar(@result));
      };
      my $frozen = Amavis::Util::freeze([$status,@result]);
      ll($ll) && do_log($ll, '[%s] run_as_subprocess: child done (%.1f ms), '.
                             'sending results: res_len=%d, %s',
                             $myownpid, $dt*1000, length($frozen), $status);
      # write results back to a parent process over a pipe as a frozen struct.
      # writing to broken pipe must return an error, not throw a signal
      local $SIG{PIPE} = sub { die "Broken pipe\n" };  # locale-independent err
      $child_out_fh->print($frozen) or die "Can't write result to pipe: $!";
      $child_out_fh->close or die "Child can't close its side of a pipe: $!";
      flush_captured_log();
      close STDOUT or die "Child can't close its STDOUT: $!";
      POSIX::_exit(0); # normal completion, avoid END and destructor processing
    } or 1;  # ignore failures, make perlcritic happy
    my $eval2_stat = $@ ne '' ? $@ : "errno=$!";
    eval {
      chomp $eval2_stat;
      if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
      # broken pipe is common when parent process is shutting down
      my $ll = $eval2_stat =~ /^Broken pipe\b/ ? 1 : -1;
      do_log_safe($ll, 'run_as_subprocess: child process [%s]: %s',
                       $myownpid, $eval2_stat);
    } or 1;  # ignore failures, make perlcritic happy
    POSIX::_exit(3);  # SIGQUIT, avoid END and destructor processing
  # POSIX::_exit(6);  # SIGABRT, avoid END and destructor processing
  }
  # parent
  ll(5) && do_log(5,"run_as_subprocess: spawned a subprocess [%s]", $pid);
  $child_out_fh->close
    or die "Parent failed to close child side of the pipe: $!";
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  prolong_timer('run_as_subprocess');  # restart the timer
  ($proc_fh, $pid);  # return pipe file handle to the subprocess and its PID
}

# read results from a subprocess over a pipe, returns a ref to a results string
# and a subprocess exit status;  close the pipe and dismiss the subprocess,
# by force if necessary; if $success_list_ref is defined, check also the
# subprocess exit status against the provided list and log results
#
sub collect_results($$;$$$) {
  my($proc_fh,$pid, $what,$results_max_size,$success_list_ref) = @_;
  # $results_max_size is interpreted as follows:
  #   undef .. no limit, read and return all data;
  #      0 ... no limit, read and discard all data, returns ref to empty string
  #   >= 1 ... read all data, but truncate results string at limit
  my $child_stat; my $close_err = 0; my $pid_orig = $pid;
  my $result = ''; my $result_l = 0; my $skipping = 0; my $eval_stat;
  eval {  # read results; could be aborted by a read error or a timeout
    my($nbytes,$buff);
    while (($nbytes=$proc_fh->read($buff,16384)) > 0) {
      if (!defined($results_max_size)) { $result .= $buff }  # keep all data
      elsif ($results_max_size == 0 || $skipping)  {}        # discard data
      elsif ($result_l < $results_max_size) { $result .= $buff }
      else {
        $skipping = 1;  # sanity limit exceeded
        do_log(-1,'collect_results from [%s] (%s): results size limit '.
                  '(%d bytes) exceeded', $pid_orig,$what,$results_max_size);
      }
      $result_l += $nbytes;
    }
    defined $nbytes or die "Error reading from a subprocess [$pid_orig]: $!";
    ll(5) && do_log(5,'collect_results from [%s] (%s), %d bytes, (limit %s)',
                      $pid_orig,$what,$result_l,$results_max_size);
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  if (defined($results_max_size) && $results_max_size > 0 &&
      length($result) > $results_max_size) {
    substr($result, $results_max_size) = '...';
  }
  if (defined $eval_stat) {  # read error or timeout; abort the subprocess
    chomp $eval_stat;
    undef $_[0];  # release the caller's copy of $proc_fh
    kill_proc($pid,$what,1,$proc_fh, "on reading: $eval_stat") if defined $pid;
    undef $proc_fh; undef $pid;
    die "collect_results - reading aborted: $eval_stat";
  }
  # normal subprocess exit, close pipe, collect exit status
  $eval_stat = undef;
  eval {
    $proc_fh->close or $close_err = $!;
    $child_stat = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    undef $proc_fh; undef $pid;
    undef $_[0];  # release also the caller's copy of $proc_fh
    1;
  } or do {  # just in case a close itself timed out
    $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    undef $_[0];  # release the caller's copy of $proc_fh
    kill_proc($pid,$what,1,$proc_fh, "on closing: $eval_stat") if defined $pid;
    undef $proc_fh; undef $pid;
    die "collect_results - closing aborted: $eval_stat";
  };
  reposition_captured_log_to_end();
  if (defined $success_list_ref) {
    proc_status_ok($child_stat,$close_err, @$success_list_ref)
      or do_log(-2, 'collect_results from [%s] (%s): %s %s', $pid_orig, $what,
                    exit_status_str($child_stat,$close_err), $result);
  } elsif ($close_err != 0) {
    die "Can't close pipe to subprocess [$pid_orig]: $close_err";
  }
  (\$result,$child_stat);
}

# read results from a subprocess over a pipe as a frozen data structure;
# close the pipe and dismiss the subprocess; returns results as a ref to a list
#
sub collect_results_structured($$;$$) {
  my($proc_fh,$pid, $what,$results_max_size) = @_;
  my($result_ref,$child_stat) =
    collect_results($proc_fh,$pid, $what,$results_max_size,[0]);
  my(@result);
  $result_ref = Amavis::Util::thaw($$result_ref);
  @result = @$result_ref  if $result_ref;
  @result
    or die "collect_results_structured: no results from subprocess [$pid]";
  my $status = shift(@result);
  $status =~ /^STATUS: (?:SUCCESS|FAILURE)\b/
    or die "collect_results_structured: subprocess [$pid] returned: $status";
  (\@result,$child_stat);
}

1;