| Current File : //usr/share/perl5/vendor_perl/Amavis/ProcControl.pm |
# 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;