Server IP : 85.214.239.14 / Your IP : 18.118.144.50 Web Server : Apache/2.4.62 (Debian) System : Linux h2886529.stratoserver.net 4.9.0 #1 SMP Tue Jan 9 19:45:01 MSK 2024 x86_64 User : www-data ( 33) PHP Version : 7.4.18 Disable Function : pcntl_alarm,pcntl_fork,pcntl_waitpid,pcntl_wait,pcntl_wifexited,pcntl_wifstopped,pcntl_wifsignaled,pcntl_wifcontinued,pcntl_wexitstatus,pcntl_wtermsig,pcntl_wstopsig,pcntl_signal,pcntl_signal_get_handler,pcntl_signal_dispatch,pcntl_get_last_error,pcntl_strerror,pcntl_sigprocmask,pcntl_sigwaitinfo,pcntl_sigtimedwait,pcntl_exec,pcntl_getpriority,pcntl_setpriority,pcntl_async_signals,pcntl_unshare, MySQL : OFF | cURL : OFF | WGET : ON | Perl : ON | Python : ON | Sudo : ON | Pkexec : OFF Directory : /proc/3/cwd/proc/3/cwd/usr/share/perl5/Amavis/ |
Upload File : |
# 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;