epics/epics-base
0
0
Fork 0
Code Issues Pull Requests Projects Wiki Activity

Kill CA & PVA clients properly if they time out

Browse Source 
Uses Win32::Process or fork() to run caget/pvget.

The system_timeout() and qx_timeout() utilities added here
should be extracted into a separate EPICS::Timeouts module.
This commit is contained in:
Andrew Johnson
2021-03-22 13:55:44 -05:00
parent e2a9678b15
commit cde7d3d254
1 changed files with 71 additions and 35 deletions
Download Patch File Download Diff File Expand all files Collapse all files

106
modules/database/test/std/rec/netget.plt
View File

@@ -3,6 +3,9 @@
use strict;
use warnings;
use if $^O eq 'MSWin32', "Win32::Process";
use if $^O eq 'MSWin32', "Win32";
use lib '@TOP@/lib/perl';
use Test::More tests => 3;
@@ -100,19 +103,6 @@ like($version, qr/^ \d+ \. \d+ \. \d+ /x,
"Got BaseVersion '$version' from iocsh");
# Client Tests
my $client = EPICS::IOC->new;
$client->debug($debug);
sub close_client {
my $doing = shift;
return sub {
diag("Timeout $doing");
$client->close;
}
}
# Channel Access
SKIP: {
@@ -129,17 +119,9 @@ SKIP: {
# CA Client test
watchdog {
$client->start($caget, '-w5', $pv);
my $caVersion = $client->_getline;
like($caVersion, qr/^ $pv \s+ \Q$version\E $/x,
'Got same BaseVersion from caget');
my @errors = $client->_geterrors;
note("Errors from caget:\n",
map(" $_\n", @errors))
if scalar @errors;
$client->close;
} 15, close_client('doing caget');
my $caVersion = qx_timeout(15, "$caget -w5 $pv");
like($caVersion, qr/^ $pv \s+ \Q$version\E $/x,
'Got same BaseVersion from caget');
}
@@ -162,17 +144,71 @@ SKIP: {
# PVA Client test
watchdog {
$client->start($pvget, '-w5', $pv);
my $pvaVersion = $client->_getline;
like($pvaVersion, qr/^ $pv \s .* \Q$version\E \s* $/x,
'Got same BaseVersion from pvget');
my @errors = $client->_geterrors;
note("Errors from pvget:\n",
map(" $_\n", @errors))
if scalar @errors;
$client->close;
} 10, close_client('doing pvget');
my $pvaVersion = qx_timeout(15, "$pvget -w5 $pv");
like($pvaVersion, qr/^ $pv \s .* \Q$version\E \s* $/x,
'Got same BaseVersion from pvget');
}
$ioc->exit;
# Process timeout utilities
sub system_timeout {
my ($timeout, $cmdline) = @_;
my $status;
if ($^O eq 'MSWin32') {
my $proc;
(my $app) = split ' ', $cmdline;
if (! Win32::Process::Create($proc, $app, $cmdline,
1, &Win32::Process::NORMAL_PRIORITY_CLASS, '.')) {
my $err = Win32::FormatMessage(Win32::GetLastError());
die "Can't create Process for '$cmdline': $err\n";
}
if (! $proc->Wait(1000 * $timeout)) {
$proc->Kill(1);
note("Timed out '$cmdline' after $timeout seconds\n");
}
my $status;
$proc->GetExitCode($status);
return $status;
}
else {
my $pid;
$status = watchdog {
$pid = fork();
die "Can't fork: $!\n"
unless defined $pid;
exec $cmdline
or die "Can't exec: $!\n"
unless $pid;
waitpid $pid, 0;
return $? >> 8;
} $timeout, sub {
kill 9, $pid if $pid;
note("Timed out '$cmdline' after $timeout seconds\n");
return -2;
};
}
return $status;
}
sub qx_timeout {
my ($timeout, $cmdline) = @_;
open(my $stdout, '>&STDOUT')
or die "Can't save STDOUT: $!\n";
my $outfile = "stdout-$$.txt";
unlink $outfile;
open STDOUT, '>', $outfile;
my $text;
if (system_timeout($timeout, $cmdline) == 0 && -r $outfile) {
open(my $file, '<', $outfile)
or die "Can't open $outfile: $!\n";
$text = join '', <$file>;
close $file;
}
open(STDOUT, '>&', $stdout)
or die "Can't restore STDOUT: $!\n";
unlink $outfile;
return $text;
}