# -*-Fundamental-*-
#
# Copyright (c) 1996 Network Appliance, Inc.
#
# You may distribute under the terms of the Artistic License, as
# specified in the README file included in the ttt distribution.
#
use English;
$ttt_vers .= "\$Id: //depot/tools/main/p4bench/tttAgents.pl#1 $/";
# tttAgents.pl
#ttt###########################################################################
#ttt#
#ttt# The following functions comprise a "package" (though they are *not*
#ttt# currently implemented a a separate perl "package") that provides
#ttt# services useful for managing (possibly remote) remote execution of
#ttt# multiple child processes. The following data structures are central
#ttt# to the service:
#ttt#
#ttt# An $agentid is the process number of the child process on the local
#ttt# host. (For remote processes, this is the pid of the rsh running on
#ttt# the local host.)
#ttt#
#ttt# A tuple of information about each agent is stored in the associative
#ttt# array %agents:
#
# $agents{$agentid,"STDIN"} filehandle for writing to the agent's stdin
# $agents{$agentid,"STDOUT"} filehandle for reading the agent's stdout
# $agents{$agentid,"STDERR"} filehandle for reading the agent's stderr
#
#ttt#
#ttt# While the above filehandle names are useful for I/O calls, the file
#ttt# numbers are useful for constructing the proper bit vector masks.
#ttt# (The convention of using names "<handle>f" for the second index in
#ttt# psuedo-multidemsional array is useful as it allows the bit to be
#ttt# accessed given an $agentid and $filehandle, i.e.,"$agents{$agenid,
#ttt# $filehandle."f"}".
#ttt#
#
# $agents{$agentid,"STDINf"} file number for writing the agent's stdin
# $agents{$agentid,"STDOUTf"} file number for reading the agent's stdout
# $agents{$agentid,"STDERRf"} file number reading the agent's stderr
# $agents{$agentid,"STDINb"} buffer for writing the agent's stdin
# $agents{$agentid,"STDOUTb"} buffer for reading the agent's stdout
# $agents{$agentid,"STDERRb"} buffer for reading the agent's stderr
# $agents{$agentid,"STDINt"} bit vec mask bit for selecting agents STDIN
# $agents{$agentid,"STDOUTt"} bit vec mask bit for selecting agents STDOUT
# $agents{$agentid,"STDERRt"} bit vec mask bit for selecting agents STDERR
# $agents{$agentid,"as"} who the cmd was run as remotely
# $agents{$agentid,"cmdPID"} PID of the command on the remote side
# $agents{$agentid,"last"} time() value for agent's latest event time
# $agents{$agentid,"name"} human-readable name for this agent
# $agents{$agentid,"onKill"} action to be taken upon call to ttt_kill_agents
# $agents{$agentid,"stattag"} status tag line from remote shell
# $agents{$agentid,"statval"} exit status tag line read from remote shell
#
#ttt# If you add anything to the above list, please update &ttt_clear_agent
#ttt# to reflect it.
#ttt#
#ttt# The %agentids array is the list of known agents. For agents which have
#ttt# not yet terminated, it is "running". For remote agents which have
#ttt# terminated, but whose output has not been entirely consumed, or whose
#ttt# remote shell terminated abnormally before writing the special in-band
#ttt# status tag line, it is "terminated.$?"; otherwise, it is the exit
#ttt# status of the child (i.e., the full 8-bit value reterned by wait(2)).
#ttt#
#
# %agentids (keyed by $agentid; "running" | "terminated.$?" | exit status )
#
#ttt# This function is a perl version of the pipe system call, using
#ttt# "socketpair". It's used internally by ttt_start_agent:
#ttt#
sub ttt_pipe
{
$_[0] = &ttt_handle;
$_[1] = &ttt_handle;
#if (! socketpair($_[0], $_[1], &AF_UNIX, &SOCK_STREAM, 0))
# am now using pipe instead of socketpair, since when using socketpair, when
# one end of the stream is closed (typically the writer), the data not yet read
# by the other end (the reader) is lost. pipe, on the other hand, retains the data
# even after one end is closed.
if (! pipe($_[0], $_[1]) )
{ &ttt_notest("ttt_pipe: pipe failed, errno = $!\n"); }
select ($_[0]); $| = 1; # set unbuffered IO
select ($_[1]); $| = 1; #
select STDOUT; # (always leave STDOUT selected)
return 1;
}
if ($MPW) { $STDINbit = 0; $STDOUTbit = 1; $STDERRbit = 2; $maccpids = 0; }
#ttt# $agentid = &ttt_start_agent_mac($hostname, $cmd, $tell, $as, $name);
#ttt#
#ttt# This function provides a spoof of the agent stuff for use under MPW.
#ttt#
sub ttt_start_agent_mac
{
local($onhost, $cmd, $tell, $as, $name) = @_;
local($cpid);
$cpid = ++$maccpids;
if ($#ttt_eng_agents > 0)
{
&ttt_exit("Can't yet support multiple agents under MPW", "notest");
exit 1;
}
if ($myhostname ne "localhost")
{
&ttt_exit("Can't yet run remote agents under MPW", "notest");
exit 1;
}
if (defined($as) && $as ne $user)
{
&ttt_exit("Can't yet run as a different user under MPW", "notest");
exit 1;
}
if ($tell) { &ttt_msg ("execute", "$cpid on $onhost: $cmd\n"); }
eval 'toolserver $cmd;';
$agentids{$cpid} = "running";
# These "file numbers" are bogus, but may be useful someday...
$fno = $cpid + $STDINbit;
vec($agents{$cpid,"STDINt"},$fno,1) = 1;
$agents{$cpid,"STDINf"} = $fno; $agents{$cpid,"STDINb"} = "";
$fno = $cpid + $STDOUTbit;
vec($agents{$cpid,"STDOUTt"},$fno,1) = 1;
$agents{$cpid,"STDOUTf"} = $fno; $agents{$cpid,"STDOUTb"} = "";
$fno = $cpid + $STDERRbit;
vec($agents{$cpid,"STDERRt"},$fno,1) = 1;
$agents{$cpid,"STDERRf"} = $fno; $agents{$cpid,"STDERRb"} = "";
$agents{$cpid,"last"} = time;
undef $eofbits;
if (defined($name)) { $agents{$cpid,"name"} = $name; }
else { $agents{$cpid,"name"} = $cpid; } # default the agent's name to its pid
return($cpid);
}
#ttt# $agentid = &ttt_start_agent($hostname, $cmd, $tell, $as, $name);
#ttt#
#ttt# > $hostname the name of the host on which run the process
#ttt# > $cmd is a shell command to be executed
#ttt# > $tell tell the world what we're starting (boolean)
#ttt# > $as if present, specifies a user to run the command
#ttt# > $name human-readable name for this agent
#ttt# < $agentid the agent id of the newly created agent.
#ttt#
#ttt# This function is used to create a child process ("agent"). The idea
#ttt# is that the caller need not be aware of whether the agent will run
#ttt# on the local host or a remote one; the semantics (command line args,
#ttt# STDIN, STDOUT, STDERR, and exit status) are identical either way.
#ttt#
#ttt# If $hostname specifies the local host, ttt_start_agent() will start
#ttt# the agent with a simple fork/exec; otherwise, rsh is used to start the
#ttt# agent on the specified remote host. In this case, $cmd is modified so
#ttt# that the remote shell appends a line containing the exit status of the
#ttt# $cmd pipeline before terminating. This extra line has a special format
#ttt# recognizable to the agent_ routines, and allows them to ascertain the
#ttt# exist status of the remote $cmd itself. (This was inspired by "ersh".)
#ttt#
sub ttt_start_agent
{
if ($MPW) { return &ttt_start_agent_mac(@_); };
local($onhost, $cmd, $tell, $as, $name) = @_;
#&ttt_msg("DEBUG", sprintf("&ttt_start_agent(%s, %s, %s, %s);\n\n", @_));
local($cpid, $fno);
local(@CSTDIN, @CSTDOUT, @CSTDERR); # handle pairs for "ttt_pipe()"
local($RD, $WR, $fno);
if (defined($as) && "$user" eq "$as") { undef($as); }
&ttt_pipe($RD, $WR); $CSTDIN[0] = $RD; $CSTDIN[1] = $WR;
&ttt_pipe($RD, $WR); $CSTDOUT[0] = $RD; $CSTDOUT[1] = $WR;
&ttt_pipe($RD, $WR); $CSTDERR[0] = $RD; $CSTDERR[1] = $WR;
if (($cpid = fork) == 0)
{
# we're in the child...
#
# "close(); close(); dup(); close();" to set up STD* in child
#
close($CSTDIN[1]); close(STDIN);
open(STDIN, "<&$CSTDIN[0]"); close($CSTDIN[0]);
close($CSTDOUT[0]); close(STDOUT);
open(STDOUT, ">&$CSTDOUT[1]"); close($CSTDOUT[1]);
close($CSTDERR[0]); close(STDERR);
open(STDERR, ">&$CSTDERR[1]"); close($CSTDERR[1]);
# is this agent supposed to run on the local host?
#
if (
($onhost eq $myhostname) || ($onhost eq "localhost")
&& ! defined($as)
)
{
#&ttt_msg("DEBUG", "execing \"$cmd\"\n");
exec "$cmd";
printf STDERR "\"exec $cmd\" failed\n"; close(STDERR);
exit 1;
}
else
{
#ttt#
#ttt# The format of the special status tag line passed to the
#ttt# remote side for echo is funky so as to handle either sh or
#ttt# csh (since the rsh will execute the remote user's
#ttt# preferred shell as set in passwd). csh will echo the $?0
#ttt# as "0" and the $status as "<exit status>", while sh will
#ttt# echo the $?0 as "<exit status>0" and the $status as "". We
#ttt# detect on this side which was used, and parse the tab
#ttt# appropriately when it is returned.
#ttt#
local($stattag) = "$$:remote:$onhost";
local($remcmd) = "echo \"ttt_cmdPID:\$\$\"; ( $cmd ); echo \"$stattag:\$?0#\$status\"";
#&ttt_msg("DEBUG", "$tttrsh $onhost $remcmd\n"); #debug#
if (defined($as))
{ exec("$tttrsh", "$onhost", "-l", $as, "$remcmd"); }
else
{ exec("$tttrsh", "$onhost", "$remcmd"); }
printf STDOUT "$stattag:10#\n"; close(STDOUT);
printf STDERR "\"exec $cmd\" failed\n"; close(STDERR);
exit 1;
}
}
else
{
# we're in the parent...
# close the unused sides of our pipes...
#
&ttt_closehandle($CSTDIN[0]);
&ttt_closehandle($CSTDOUT[1]);
&ttt_closehandle($CSTDERR[1]);
# record the attempt to start the agent
#
if ($tell)
{
if (defined($as))
{ &ttt_msg
("execute", "$cpid on $onhost: $cmd (as user \"$as\")\n"); }
else
{ &ttt_msg
("execute", "$cpid on $onhost: $cmd\n"); }
}
$agentids{$cpid} = "running";
if ($onhost eq $myhostname && ! defined($as))
{ $agents{$cpid,"stattag"} = "local"; }
else
{ $agents{$cpid,"stattag"} = "$cpid:remote:$onhost"; }
$agents{$cpid,"STDIN"} = $CSTDIN[1];
$fno = fileno($agents{$cpid,"STDIN"});
$agents{$cpid,"STDINt"} = "";
vec($agents{$cpid,"STDINt"},$fno,1) = 1;
$agents{$cpid,"STDINf"} = $fno; $agents{$cpid,"STDINb"} = "";
$agents{$cpid,"STDOUT"} = $CSTDOUT[0];
$fno = fileno($agents{$cpid,"STDOUT"});
$agents{$cpid,"STDOUTt"} = "";
vec($agents{$cpid,"STDOUTt"},$fno,1) = 1;
$agents{$cpid,"STDOUTf"} = $fno; $agents{$cpid,"STDOUTb"} = "";
$agents{$cpid,"STDERR"} = $CSTDERR[0];
$fno = fileno($agents{$cpid,"STDERR"});
$agents{$cpid,"STDERRt"} = "";
vec($agents{$cpid,"STDERRt"},$fno,1) = 1;
$agents{$cpid,"STDERRf"} = $fno; $agents{$cpid,"STDERRb"} = "";
if (defined($name)) { $agents{$cpid,"name"} = $name; }
else { $agents{$cpid,"name"} = $cpid; } # default agent's name to its pid
# for local agents, cmdPID can just be the command's PID
# this will allow ttt_kill_agents to still kill all processes
# it has spawned
if ($agents{$cpid,"stattag"} eq "local")
{
$agents{$cpid,"cmdPID"} = $cpid;
}
elsif (defined($as)) { $agents{$cpid,"as"} = $as; }
$agents{$cpid,"last"} = time;
return $cpid;
}
}
sub ttt_get_statval
{
local($agentid) = @_;
$agentids{$agentid} = $agents{$agentid,"statval"};
if ($agentids{$agentid} =~ /0#\n$/) # remote was bourne shell
{
$agentids{$agentid} =~
s/$agents{$agentid,"stattag"}:(.*)0#\n$/$1/;
}
else
{
$agentids{$agentid} =~
s/$agents{$agentid,"stattag"}:(.*)#(.*)\n$/$2/;
}
}
#ttt# $agentid = &ttt_start_agent_windows($hostname, $windowshostname, $cmd,
#ttt# [$tell, [$as, [$name]]]);
#ttt#
#ttt# > $hostname the name of the UNIX host from which to rshell
#ttt# > $windowshostname the windows host on which to run the command
#ttt# > $cmd is a shell command to be executed
#ttt# > $tell tell the world what we're starting (boolean)
#ttt# > $as if present, specifies a user to run the command
#ttt# > $name human-readable name for this agent
#ttt# < $agentid the agent id of the newly created agent.
#ttt#
#ttt# This function is used as a wrapper to call ttt_start_agent with the correct
#ttt# input to get it to talk to a Windows machine.
sub ttt_start_agent_windows
{
my ($onhost, $windowshostname, $cmd, $tell, $as, $name) = @_;
$cmd = "$tttroot/winrsh $windowshostname $cmd";
return(&ttt_start_agent($onhost,$cmd,$tell,$as,$name));
}
#ttt# $status = &ttt_close_agent($agentid[, $do_wait]);
#ttt#
#ttt# > $agentid The agentid of the agent to deallocate
#ttt# > $do_wait Whether to wait politely for the agent
#ttt# < $status The exit status of the agent
#ttt#
#ttt# This function closes the file descriptors of an agent.
#ttt#
sub ttt_close_agent
{
my ($agentid, $do_wait) = @_;
#&ttt_msg("DEBUG", sprintf("&ttt_close_agent(%s, %s);\n\n", @_));
if (! defined($do_wait))
{
if ($UNIX) { $do_wait = 1; }
if ($MPW) { $do_wait = 0; }
}
local ($status);
# close the file descriptors
#
if ($do_wait) { &ttt_wait_agent($agentid); }
if ($MPW) { $status = 0; } # spooferino
if ($UNIX)
{
$status = $agentids{$agentid};
&ttt_closehandle($agents{$agentid,"STDIN"});
&ttt_closehandle($agents{$agentid,"STDOUT"});
&ttt_closehandle($agents{$agentid,"STDERR"});
close($agents{$agentid,"STDIN"});
close($agents{$agentid,"STDOUT"});
close($agents{$agentid,"STDERR"});
}
&ttt_clear_agent($agentid);
return ($status);
}
sub ttt_clear_agent
{
my ($agentid) = @_;
if ($UNIX)
{
delete $agents{$agentid,"STDIN"};
delete $agents{$agentid,"STDOUT"};
delete $agents{$agentid,"STDERR"};
delete $agents{$agentid,"stattag"};
delete $agents{$agentid,"statval"};
}
delete $agents{$agentid,"STDINf"};
delete $agents{$agentid,"STDOUTf"};
delete $agents{$agentid,"STDERRf"};
delete $agents{$agentid,"STDINb"};
delete $agents{$agentid,"STDOUTb"};
delete $agents{$agentid,"STDERRb"};
delete $agents{$agentid,"STDINt"};
delete $agents{$agentid,"STDOUTt"};
delete $agents{$agentid,"STDERRt"};
if (defined($agents{$agentid,"as"})) { delete $agents{$agentid,"as"}; }
delete $agents{$agentid,"cmdPID"};
delete $agents{$agentid,"last"};
delete $agents{$agentid,"name"};
delete $agents{$agentid,"onKill"};
delete $agentids{$agentid};
}
#ttt# ($line, $buf) = &ttt_nextline($buf);
#ttt#
#ttt# > $buf the buffer a (string) to return next line from
#ttt# < $line the returned line
#ttt# < $buf the updated buffer
#ttt#
#ttt# A utility routine used by ttt_readline_agents. Removes the next full
#ttt# line (as delimited by a newline) out of the buffer, updating the
#ttt# buffer, and returns it.
#ttt#
sub ttt_nextline
{
my ($buf) = @_;
my ($line);
my ($nlindex) = index($buf, "\n");
if ($nlindex == -1) { return ($buf, ""); }
$line = substr($buf, 0, $nlindex+1);
$buf = substr($buf, $nlindex+1, length($buf) - $nlindex);
#&ttt_msg("DEBUG", "line == $line\n");
return ($line, $buf);
}
if ($H_OS eq "SunOS")
{ $WNOHANG = 0100; }
elsif ($H_OS eq "IRIX" && $H_OSVER =~ /^5./)
{ $WNOHANG = 0100; }
else
{ $WNOHANG = 1; }
#ttt# &ttt_agent_exits($rbits);
#ttt#
#ttt# > $rbits only act on agents selected by $rbits vector
#ttt#
#ttt# For all terminated remote agents, if we saw the
#ttt# $agents{$agentid,"statval"}, then record the agent's exit status in
#ttt# %agentids. If $rbits in undefined, will act on all agents.
#ttt#
sub ttt_agent_exits
{
local ($rbits) = @_;
reapstat: foreach $agentid (keys(%agentids))
{
# record the status tag (if applicable)
#
if ($agentids{$agentid} eq "running") { next reapstat; }
# If any agent has terminated, and we have the status tag in the
# special status tag buffer, that's what it really is! Record it in
# %agentids.
#
if (
(defined($agentids{$agentid})) and
($agentids{$agentid} =~ /^terminated\./) and
(defined($agents{$agentid,"statval"})) and
($agents{$agentid,"statval"}) and
((! defined($rbits)) or vec($rbits, $agents{$agentid,$H."f"}, 1))
)
{
&ttt_get_statval($agentid);
}
}
}
sub ttt_readline_agents_mac
{
local($rbits, $timeout) = @_;
local($theagentid);
# First, do we already have a line in our buffers that can satisfy the
# request? (The foreach loop is there for the day when we add multiple
# agent support).
#
foreach $agentid (keys(%agentids))
{
$theagentid = $agentid; # An egregious assumption that we have only one!
foreach $H ("STDERR","STDOUT")
{
#printf "checking buffer for --> $agentid.$H <--\n";
if ($agents{$agentid,$H."b"} ne "")
{
# Note: this assumes we never have partial lines in the
# buffers!
#
($line, $agents{$agentid,$H."b"}) =
&ttt_nextline($agents{$agentid,$H."b"});
return($line, $agentid, $H);
}
}
}
# Now get an event...
#
# TBD - handle > 1 started agent someday - the following all assumes only 1:
#
getevent: while (1)
{
if (defined($eofbits)) { last getevent; }
eval '$event = gethlevent
(5, "TSEE", "cout", "TSEE", "cerr", "TSEE", "dump", "aevt", "ansr")';
$agentid = $theagentid; # (for now)
if (substr($event,0,8) eq "aevtansr")
{
# An agent terminated... implies EOF on it's descriptors...
#printf "ttt_readline_agents_mac(): pid $agentid terminated\n";
#printf "ttt_readline_agents_mac(): event was <$event>\n"; #debug#
$agentids{$agentid} = "terminated"; #TBD# need to get real status
$agents{$agentid,"last"} = time;
$eofbits = $eofbits | $agents{$agentid,"STDOUT"."t"};
$eofbits = $eofbits | $agents{$agentid,"STDERR"."t"};
last getevent;
}
($eclass, $eid, $_) = &ttt_splitevent($event);
if ($eid eq "cout" || $eid eq "dump")
{ $H = "STDOUT"; } else { $H = "STDERR"; }
if (vec($rbits, $agents{$agentid,$H."f"}, 1))
{ return ($_."\n", $agentid, $H); }
$agents{$agentid,$H."b"} = $agents{$agentid,$H."b"}.$_."\n";
}
chkeof: foreach $agentid (keys(%agentids))
{
# Now, if we have dribbles left over in the buffers we've see eof on,
# return them (subject to the $rbits), OR return eof. (But return eof
# on a given descriptor ONLY once.
#
# Note: Under MPW, with the current mechanism that we read input, we
# should be getting partial lines of output, so the "check for dribbles"
# part proabably isn't necessary, but it doesn't hurt anything either.
# And since it may be useful in the future, (depending on how multiple
# agent support is implemented), let's leave it in. OK?
#
# I just knew you'd agree.
#
foreach $H ("STDERR","STDOUT")
{
if (vec($rbits, $agents{$agentid,$H."f"}, 1)
&& (vec($eofbits, $agents{$agentid,$H."f"}, 1)))
{
if (defined ($agents{$agentid,$H."b"}))
{
if ($agents{$agentid,$H."b"})
{
$buf = $agents{$agentid,$H."b"};
# leave buffer empty, but def
$agents{$agentid,$H."b"} = "";
}
else
{
delete $agents{$agentid,$H."b"};
return (undef, $agentid, $H); # return EOF
}
}
return($buf, $agentid, $H);
}
}
}
return(""); # "timeout" return
}
#ttt# ($line,$agentid,$stream) = &ttt_readline_agents($rbits,$timeout,$dontwait,$stoponerr,$partial);
#ttt#
#ttt# >$rbits a bit vector specifying streams to read
#ttt# >$timeout a timeout value is seconds; 0 = return immed.
#ttt# >$dontwait if defined, don't do wait for child status
#ttt# >$stoponerr if defined, override error code for select
#ttt# >$partial whether the caller will except partial lines
#ttt# <$line the line of output retrieved, or undef if agent is
#ttt# terminated
#ttt# <$agentid the ID of the agent which has provided the output
#ttt# <$stream "STDOUT" or "STDERR" where appropriate
#ttt#
#ttt# This function is used to read input from one or more of the running
#ttt# agents, and to handle termination of agents.
#ttt#
#ttt# If a complete line of output can be formed from one of the selected
#ttt# agents, then it will be returned in the $line element of the
#ttt# function value list, with $agentid and $stream ("STDOUT" or
#ttt# "STDERR") indicating which stream the line comes from.
#ttt#
#ttt# Otherwise, if an agent corresponding to one of the selected streams
#ttt# has terminated, and some data (not containing a newline) from the
#ttt# selected stream remains in the buffer, it will be returned. in
#ttt# $line (again with $agentid and $stream identifying the stream).
#ttt#
#ttt# Otherwise, if an agent corresponding to one of the selected streams
#ttt# has terminated, and no data from the selected stream remains in the
#ttt# buffer, $line will be returned undefined as an end of file
#ttt# indicator. (Again with $agentid and $stream identifying the stream).
#ttt# This indication will only be returned on the first attempt to read a
#ttt# stream after all data for the stream has been returned. (This is
#ttt# important since it allows processing to proceed to other streams
#ttt# which may have been selected and have a partial line buffered or a
#ttt# pending EOF condition; otherwise, they would never get their chance
#ttt# to return EOF.)
#ttt#
#ttt# Otherwise, if $partial is set, and, after the expiry of the timeout
#ttt# limit, data is present in the buffer for any of the selected streams
#ttt# (but lacking a newline -- else it would have been returned, above),
#ttt# then the data for one of the streams is returned.
#ttt#
#ttt# Otherwise, $line returns "", indicating that no data was read, and nor
#ttt# did any agent corresponding to one of the selected streams terminate,
#ttt# within the timeout limit.
#ttt#
#ttt# $stoponerr is used to determine how to handle errors from select.
#ttt# Most of the time, if select returns an error, it's indicative that
#ttt# we've been interupted by a signal and the current way we handle that
#ttt# is by calling &ttt_notest which will exit (implicitly assuming the
#ttt# signal was meant to stop the works). There can be a situation
#ttt# where we want the ability to be interupted by a signal and not to
#ttt# exit - rather, we want to continue execution. We default to the old
#ttt# behaviour and you can override the error handling code by defining
#ttt# that parameter.
#ttt#
#ttt# THIS FUNCTION SHOULD BE USED FOR ALL IO READING THE OUTPUT OF
#ttt# AGENTS. Other functions, with different calling semantics, but which
#ttt# observe the same protocols, may be implemented in the future.
#ttt#
sub ttt_readline_agents
{
if ($MPW) { return &ttt_readline_agents_mac(@_); };
local ($rbits, $timeout, $dontwait, $stoponerr, $partial) = @_;
#&ttt_msg("DEBUG", sprintf("&ttt_readline_agents(%s, %s);\n\n", @_));
local ($buf, $line, $rout, $agentid, $cpid, $H, $selbits, $eofbits);
local ($gotdata, $sel, $n);
local ($rdbufsize) = 8*1024;
local ($exstat);
# First, do we already have a line in our buffers that can satisfy the
# request?
#
#&ttt_msg("DEBUG", "check buffers...\n");
foreach $agentid (keys(%agentids))
{
foreach $H ("STDERR","STDOUT")
{
if (vec($rbits, $agents{$agentid,$H."f"}, 1)
&& $agents{$agentid,$H."b"} =~ "\n")
{
($line, $agents{$agentid,$H."b"}) =
&ttt_nextline($agents{$agentid,$H."b"});
if ($ttt_readline_nocrs) { $line =~ s/\r//g; }
return($line, $agentid,$H);
}
}
}
#&ttt_msg("DEBUG", "check for terminated children...<$WNOHANG>\n");
#
# Any terminated children?
# (only if $dontwait is not defined (usual case))
#
if (! defined($dontwait))
{
while (($agentid = waitpid(-1, $WNOHANG)) > 0)
{
$exstat = $?;
#&ttt_msg("DEBUG", "ttt_readline_agents(): pid $agentid termed $?\n");
if ($agents{$agentid,"stattag"} ne "local")
{ $agentids{$agentid} = "terminated.$?"; }
else
{ $agentids{$agentid} = $exstat; }
$agents{$agentid,"last"} = time;
}
}
#&ttt_msg("DEBUG", "check ttt_agent_exits...\n");
&ttt_agent_exits($rbits);
# If we have any agents who have terminated, but have not yet returned
# eof on both descriptors, set the select timeout to 0, since we can
# return an eof for sure if nothing selects for reading.
#
#&ttt_msg("DEBUG", "check eof s...\n");
checkeof: foreach $agentid (keys(%agentids))
{
foreach $H ("STDERR","STDOUT")
{
if (($agentids{$agentid} ne "running")
&& (vec($rbits, $agents{$agentid,$H."f"}, 1))
&& ($agents{$agentid,$H."b"}))
{ $timeout = 0; last checkeof; }
}
}
# If we get here, we didn't have a line already. Let's fish for a file
# ready to read...
#
$selbits = $rbits; $eofbits = "";
#&ttt_msg("DEBUG", "go fish...\n");
fishing: while (1)
{
# $gotdata insures that we don't hang in this loop selecting on
# streams that only have "eof" to return!
#
$gotdata = 0;
#&ttt_msg("DEBUG", "select(\$rout = $selbits, undef, undef, $timeout)\n");
$sel = select($rout = $selbits, undef, undef, $timeout);
# This stoponerr stuff was added by someone else between Magic
# and Netapp... ? - rmg
#
if ($sel < 0)
{
if (!defined($stoponerr))
{ &ttt_notest("select failed, errno = $!\n"); }
else { next fishing; }
}
elsif ($sel == 0)
{ last fishing; } # the select timed out
else # ($sel > 0) # there's something to read that won't block
{
# somebody's ready to read... who is it?
#
agent: foreach $agentid (keys(%agentids))
{
stream: foreach $H ("STDERR","STDOUT")
{
# Anything to read on this file descriptor?
#
if (vec($rout, $agents{$agentid,$H."f"}, 1))
{
# Now do the read....
#
#&ttt_msg("DEBUG", "read agentid=$agentid $H..."); #debug#
$buf = "";
if (! defined ($n =
sysread($agents{$agentid,$H}, $buf, $rdbufsize)))
{
if ( $H_OS eq "SunOS" && $H_OSVER =~ /^5/ )
{ $! = &EIO; } # added by dag #
if (($H_OS eq "SunOS" && $H_OSVER =~ /^5/) &&
$! eq "I/O error")
{
# apparently, read() on Solaris will only return
# a zero-length read for "eof" once; after that,
# you get an I/O error, though select will keep
# returning "ready to read" until the fd is
# closed. Hence, we recognize this, and fake it:
$n = 0;
}
else { &ttt_notest("read failed, errno = $!\n"); }
}
if ($n == 0)
{
$eofbits = $eofbits | $agents{$agentid,$H."t"};
next stream;
}
$gotdata = 1;
# OK, do we have a bogus stashed status return?
# (cause it really isn't one, if more came from this
# file!
#
if (($H eq "STDOUT") && $agents{$agentid,"statval"})
{
# ...yes, so put it back in the buffer
$agents{$agentid,$H."b"} =
$agents{$agentid,$H."b"}.$agents{$agentid,"statval"};
$agents{$agentid,"statval"} = "";
}
$agents{$agentid,"last"} = time; # note time of read
$agents{$agentid,$H."b"} = $agents{$agentid,$H."b"}.$buf;
# Is this the PID of the command on the remote side?
#
if (($H eq "STDOUT") &&
($agents{$agentid,$H."b"}
=~ /ttt_cmdPID:([0-9]+)\n/) &&
(!defined($agents{$agentid,"cmdPID"}))
)
{
# yep, let's store it, and remove it from the buffer
$agents{$agentid,"cmdPID"} = $1;
$agents{$agentid,$H."b"}
=~ s/ttt_cmdPID:[0-9]+\n//;
#&ttt_msg("DEBUG",$agents{$agentid,"name"} .
# " cmdPID set to " .
# $agents{$agentid,"cmdPID"} .
# "\n"
# );
}
# Could this be the special remote status return?
#
#printf "IS... <".$agents{$agentid,$H."b"}.">\n"; #debug#
if (($H eq "STDOUT") &&
($agents{$agentid,$H."b"}
=~ /($agents{$agentid,"stattag"}:[0-9]+#[0-9]*\n)$/))
{
# ...yes, stash it in the special value buffer
#
$agents{$agentid,"statval"} = $1;
$agents{$agentid,$H."b"}
=~ s/$agents{$agentid,"stattag"}:[0-9]+#[0-9]*\n$//;
}
# Do we now have a full line in the buffer?
#
if ($agents{$agentid,$H."b"} =~ /\n/)
{
# we now have a line to return
#
($line, $agents{$agentid,$H."b"}) =
&ttt_nextline($agents{$agentid,$H."b"});
if ($ttt_readline_nocrs) { $line =~ s/\r//g; }
return($line, $agentid, $H);
}
}
}
}
}
if (! $gotdata) { last fishing; }
# If we got something with partial set, then wait at most 1 second
# more for anything to arrive...
#
if ($partial && $timeout > 0) { $timeout = 1; }
}
# OK. When we get here, we can't be ready to return a whole line to
# satisfy the request, because we'd have returned it.
chkeof: foreach $agentid (keys(%agentids))
{
# Now, if we have dribbles left over in the buffers we've see eof on,
# return them (subject to the rbits), OR return eof. (But return eof
# on a given descriptor ONLY once.
#
foreach $H ("STDERR","STDOUT")
{
if (vec($rbits, $agents{$agentid,$H."f"}, 1)
&& (vec($eofbits, $agents{$agentid,$H."f"}, 1)))
{
if (defined ($agents{$agentid,$H."b"}))
{
if ($agents{$agentid,$H."b"})
{
$buf = $agents{$agentid,$H."b"};
# leave buffer empty, but def
$agents{$agentid,$H."b"} = "";
}
else
{
delete $agents{$agentid,$H."b"};
return (undef, $agentid, $H); # return EOF
}
}
if ($ttt_readline_nocrs) { $buf =~ s/\r//g; }
return($buf, $agentid, $H);
}
}
}
#
#
if ($partial)
{
chkpartail: foreach $agentid (keys(%agentids))
{
# If we have partial lines in the buffer for any selected stream,
# return *it*...
#
foreach $H ("STDERR","STDOUT")
{
if (vec($rbits, $agents{$agentid,$H."f"}, 1))
{
if (defined ($agents{$agentid,$H."b"}))
{
if ($agents{$agentid,$H."b"})
{
$buf = $agents{$agentid,$H."b"};
# leave buffer empty, but def
$agents{$agentid,$H."b"} = "";
if ($ttt_readline_nocrs) { $buf =~ s/\r//g; }
return($buf, $agentid, $H);
}
}
}
}
}
}
return(""); # timeout return
}
#ttt# &ttt_wait_agent($agentid);
#ttt#
#ttt# > $agentid the pid (agent id) of the agent to wait for.
#ttt# < void the pid (agent id) of the agent to wait for.
#ttt#
#ttt# This routine can be used to insure that an agent has terminated,
#ttt# and had its exit status recorded in $agents{$agentid,"statval"}.
#ttt#
sub ttt_wait_agent
{
my ($agentid) = @_;
my ($pid, $exstat);
if ($MPW) { return; } # Maybe wait until all EOFS someday...
&ttt_agent_exits;
#&ttt_msg("DEBUG", "ttt_wait_agent(): waitpid($agentid, 0)\n"); #debug#
#&ttt_msg("DEBUG", "ttt_wait_agent(): stattag: <$agents{$agentid,'stattag'}>...\n");
#ttt# Wait for the agent...
#ttt#
$pid = waitpid($agentid, 0);
$exstat = $?;
#ttt# Had it already been reaped?
#ttt#
if ($pid != $agentid)
{
#printf "ttt_wait_agent(): no such agent\n"; #debug#
#ttt# Yes; if it was remote, see if we can get the status for it;
#ttt# if ($agentids{$agentid} =~ /^terminated/)
{
#ttt# In case the remote sh never really ran, use the rsh exit
#ttt# status, which was saved in $agentids{$agentid} as
#ttt# "terminated.<status>".
#ttt#
$agentids{$agentid} =~ s/^terminated.//;
#ttt# Now, if we -did- see the special status tag line, use it.
#ttt#
if ($agents{$agentid,"statval"})
{ &ttt_get_statval($agentid); }
}
#ttt# If the agent was local, we already saved the exist status;
#ttt# nothing more to do!
#ttt#
}
else #ttt# We just reaped the agent.
{
$agents{$agentid,"last"} = time;
if ($agents{$agentid,"stattag"} eq "local")
#ttt#
#ttt# For local agents, it's simply the status returned by waitpid...
#ttt#
{ $agentids{$agentid} = $exstat; }
else
{
#ttt# But for remotes, it depends on whether we have the
#ttt# special status tag line...
#ttt#
if ($agents{$agentid,"statval"})
#ttt#
#ttt# If so, use it!
#ttt#
{ &ttt_get_statval($agentid); }
else
#ttt#
#ttt# Otherwise, just use the waitpid return
#ttt#
{ $agentids{$agentid} = $exstat; } #ttt# otherwise, use
}
}
}
#ttt# $rbits = &ttt_read_agents
#ttt# ($rbits,[$timeo,[$online,[$oneof,[$ontimeo,[$dontwait,[$partial,
#ttt# [$expectre,[$nixpectre,[$expectimeo,[$checkRbits,[$mode]]]]]]]]]]);
#ttt#
#ttt# $rbits = &ttt_read_agents(\%params);
#ttt#
#ttt# > \%params reference to a hash which specifies the parameters by name
#ttt#
#ttt# > $rbits a bit vector specifying streams to read
#ttt# > $timeo the timeout (secs) value between agent output
#ttt# > $online text to be eval'ed in the loop for lines read
#ttt# > $oneof text to be eval'ed in the loop for eof
#ttt# > $ontimeo text to be eval'ed in the loop for timeouts
#ttt# > $dontwait if defined, don't wait for child to change status
#ttt# > $partial accept partial line date
#ttt# > $expectre "expect" text we're looking for
#ttt# > $nixpectre if $expectre ne "" && this matches, return (-1, $line)
#ttt# > $expectimeo total timeout interval, in seconds. (Also applies
#ttt# if set in non "expect" mode)
#ttt# > $checkRbits rbits for agents which are to be checked, but which do
#ttt# not impact the continuation of the while loop (below)
#ttt# > $mode the mode in which this function should operate
#ttt# < ($rbits, @ret) the $rbits vector, reflecting any eof files
#ttt#
#ttt# Note: the practice of having $online contain code doing return()s
#ttt# has become pervasive, despite the fact that the original
#ttt# interface did not allow this. Unfortunately, this broke when we
#ttt# converted to perl5, since in perl5 return in an eval simply
#ttt# terminates the eval - it does *not* blow back to the caller of
#ttt# the routine that is doing the eval, as it did in perl4. To
#ttt# accomodate this, and as a general improvement in the service,
#ttt# $online (etc) can now contain a string naming a function to be
#ttt# called-back into. If this function wishes to do a "blow back"
#ttt# return, it need merely return a list containing a defined first
#ttt# element (but, the "blow-back" return list will have $rbits first!)
#ttt# If it wishes ttt_read_agents to continue, it should
#ttt# return an undef.
#ttt#
#ttt# This routine encapsulates the while { ttt_readline_agents } loop
#ttt# commonly used to read the output of one or more agents until all have
#ttt# returned eof on a set of file descriptors. Since the basic structure
#ttt# of the loop is the same, but the particular actions desired when a
#ttt# line is read, an eof is encountered, or the ttt_readline_agents()
#ttt# times out, these actions can be specified as text to exec in the $on*
#ttt# arguments.
#ttt#
#ttt# Only the $rbits argument is mandatory; the remaining arguments can be
#ttt# elided (or passed as "undef"), to get the following defaults:
#ttt#
#ttt# $timeo 30 seconds
#ttt# $online: print the line read (using ttt_msg())
#ttt# $oneof: print an eof notice identifying the descriptor returning eof
#ttt# $ontimeo: print a "timeout" message (but doesn't exit the loop).
#ttt# $dontwait: do wait for the child process to change status
#ttt# $partial: false (require full line output from agents)
#ttt# $expectre: do "expect" pattern matching
#ttt# $nixpectre: don't do "expect" pattern matching
#ttt# $expectimeo: undef...: if $expectre is undef (or ""), the first $timeo
#ttt# timeout will terminate the "expect";
#ttt# otherwise, no effect.
#ttt# $mode: 0 : old-style (see below)
#ttt#
#ttt# More explanation of unusual parameters:
#ttt# $checkRbits: rbits which correspond to agents to display output from, but
#ttt# which do not count w/r/t determining whether the subroutine
#ttt# should continue to try to grab more output from any agents.
#ttt#
#ttt# ttt_read_agents now has the concept of modes which dictate its behavior.
#ttt# here are the current modes:
#ttt# 0 (undef) : This mode, also known as "original flavor," will preserve
#ttt# the original functionality of ttt_read_agents. Features of
#ttt# this mode are actually better defined by other modes, and how
#ttt# they differ from this mode.
#ttt#
#ttt# 1 : This mode, known as "Traffic Cop Mode," will impose strict
#ttt# timeout rules on the monitored agents. It differs from
#ttt# original flavor in that the passed timeout value is considered
#ttt# to be the maximum allowable run time for the function. In
#ttt# original flavor, timeouts only occur when nothing is heard
#ttt# from the agent in the specified interval. If a value is passed
#ttt# in the $expectimeo parameter, that value will be the time
#ttt# limit for the function, with periodic timeouts every $timeo
#ttt# seconds (like original flavor).
#ttt#
#ttt# 2 : This mode, known as "L.A. Traffic Cop Mode," is really a
#ttt# modification to mode 1. Mode 1 will just cause a return
#ttt# from the function if the loop times out. This mode will
#ttt# instead kill any agents specified in the $rbits parameter
#ttt# which have timed out before returning.
#ttt#
#ttt# Return values:
#ttt# - $rbits will always be returned, with the terminated agents' rbits masked
#ttt# out where appropriate
#ttt# - @ret is the relatively strange return value:
#ttt# - $ret[0] == 0 => failure
#ttt# - $ret[0] == -1 => $nixpectre matched, $ret[1] contains the matched line
#ttt# - $ret[0] == 1 => $expectre matched, $ret[1] contains the matched line
#ttt#
sub ttt_read_agents
{
local($rbits, $timeo, $online, $oneof, $ontimeo,
$dontwait, $partial, $expectre, $nixpectre,
$expectimeo, $checkRbits, $mode) = @_;
local($line, $stream, $agentid, $H, @ret);
my($expectimer, $time_to_stop);
if (ref($_[0]) eq "HASH") # all parameters passed in a hash instead of a list
{
$rbits = ${$_[0]}{rbits};
$timeo = ${$_[0]}{timeo};
$online = ${$_[0]}{online};
$oneof = ${$_[0]}{oneof};
$ontimeo = ${$_[0]}{ontimeo};
$dontwait = ${$_[0]}{dontwait};
$partial = ${$_[0]}{partial};
$expectre = ${$_[0]}{expectre};
$nixpectre = ${$_[0]}{nixpectre};
$expectimeo = ${$_[0]}{expectimeo};
$checkRbits = ${$_[0]}{checkRbits};
$mode = ${$_[0]}{mode};
}
if (!defined($checkRbits)) { $checkRbits = ""; }
my ($new_rbits) = $rbits | $checkRbits;
if (! defined($timeo)) { $timeo = 30; }
if (! defined($online))
{ $online="&ttt_msg(\$agents{\$agentid,\"name\"}, \"\$stream: \$line\");"; }
if (! defined($oneof))
{ $oneof = "&ttt_msg(\$agents{\$agentid,\"name\"}, \"\$stream: EOF\\n\");"; }
if (! defined($ontimeo))
{ $ontimeo="&ttt_msg(\" \", \"timeout\n\")"; }
if (! defined($expectre)) { $expectre = ""; }
if (! defined($nixpectre)) { $nixpectre = ""; }
if (! defined($mode)) { $mode = 0; }
if (! defined($expectimeo) and (($mode == 1) or ($mode == 2)))
{
$expectimeo = $timeo;
}
# make sure that $checkRbits is 0 padded to the correct length
# to match $new_rbits as a string
if (defined($checkRbits))
{
my $length = length(unpack("b*",$new_rbits));
$checkRbits = pack("b$length",unpack("b*",$checkRbits));
}
$expectimer = 0;
if (($mode == 1) or ($mode == 2))
{
# okay, let's make sure this darn thing times out after the
# specified interval, rather than if it receives no output from
# any agents in the specified interval.
$time_to_stop = time + $expectimeo;
}
# The somewhat obfuscated approach to doing the "return @ret" is a
# workaround for our favorite perl5.001e bug (see the comment
# containing /perl5/ in tttLib.pl)
#
reader: while (! defined($ret[0]))
{
if (($mode == 1) or ($mode == 2))
{
if (($time_to_stop - time) < $timeo) { $timeo = $time_to_stop - time; }
if ($timeo > 0)
{
($line, $agentid, $stream) = &ttt_readline_agents($new_rbits, $timeo, $dontwait, undef, $partial);
}
elsif ($mode == 1) { @ret = (0); last reader; }
elsif ($mode == 2) # kill off any agents which we don't want anymore
{
my (@doomed_pids);
# don't want to kill the agents we didn't expect to die
$new_rbits &= $rbits; # so, we select only those in rbits left in new_bits
findopen: foreach $agentid (keys(%agentids))
{
if (vec($new_rbits, $agents{$agentid,"STDOUTf"}, 1) or
vec($new_rbits, $agents{$agentid,"STDERRf"}, 1))
{
push @doomed_pids, $agentid;
}
}
if (defined(@doomed_pids))
{
&ttt_msg("info","MOO HA HA!, killing " . join(",",@doomed_pids) . "\n");
# kill them off, but let the caller call ttt_close_agent on each
&ttt_kill_agents("KILL", @doomed_pids); # KILL might be a bit harsh
}
@ret = (0); last reader;
}
}
else # original flavor
{
($line, $agentid, $stream) = &ttt_readline_agents($new_rbits, $timeo, $dontwait, undef, $partial);
}
if (! defined($line)) # a stream was terminated (an agent finished)
{
my $tmp_rbits;
#&ttt_msg(
# "DEBUG","stream was terminated, name: ".
# $agents{$agentid,"name"}.
# ", stream: ".
# $stream.
# "\n"
# );
# this will pull out agents from checkRbits if they end first, and
# although this was never the intention of checkRbits, I should handle
# it properly. However, if I don't mask out bits from checkRbits,
# new_rbits will become useless if an agent in checkRbits ends.
# - mlewin 1998/01/16
$new_rbits = $new_rbits ^ $agents{$agentid, $stream."t"};
if (defined(&$oneof)) { @ret = &$oneof(); }
else { eval $oneof; }
# if all of the agents we care about have stopped spewing, leave reader
if (defined($checkRbits)) # mask out the bits we are just checking
{
$tmp_rbits = $new_rbits & ~$checkRbits;
}
else { $tmp_rbits = $new_rbits; }
if ($tmp_rbits eq ($tmp_rbits ^ $tmp_rbits)) { last reader; }
}
elsif ($line ne "") # got a line of text
{
if ($expectre ne "")
{
if ($line =~ /$expectre/) { @ret = (1, $line); }
elsif ($nixpectre ne "" && $line =~ $nixpectre) { @ret = (-1, $line); }
else { $expectimer = 0; }
}
elsif ($rbits & $agents{$agentid, $stream."t"}) { $expectimer = 0; }
if ($partial && $line !~ /\n$/) { $line .= "\n"; }
if (defined(&$online)) { @ret = &$online(); }
else { eval $online; }
}
else # the return was a timeout
{
if ($mode == 0) { $expectimer += $timeo; }
if ($expectre ne "")
{
if ($expectimer >= $expectimeo)
{ @ret = (0); }
}
else
{
if ($mode == 0)
{
if (defined($expectimeo))
{
if ($expectimer >= $expectimeo)
{ @ret = (0); last reader; }
}
}
if (defined(&$ontimeo)) { @ret = &$ontimeo(); }
else { eval $ontimeo; }
}
}
if (defined($ret[0])) { last reader; }
findopen: foreach $agentid (keys(%agentids))
{
foreach $H ("STDERR","STDOUT")
{ if (vec($new_rbits, $agents{$agentid,$H."f"}, 1)) { next reader; } }
}
last reader;
}
if (defined($checkRbits)) # mask out the bits we are just checking
{
$rbits = $new_rbits & ~$checkRbits;
}
else { $rbits = $new_rbits; }
return ($rbits, @ret);
}
#ttt# ($status[, $output]) = &ttt_rexec($hostname, $cmd, [$tell, [$timeo,
#ttt# [$online, [$oneof, [$ontimeo, [$as, [$ltimeo,
#ttt# [$checkRbits, [$mode, [$name]]]]]]]]]]);
#ttt#
#ttt# ($status[, $output]) = &ttt_rexec(\%params);
#ttt#
#ttt# > \%params reference to a hash which specifies the parameters by name
#ttt#
#ttt# > $hostname the name of the host on which run the process
#ttt# > $cmd is a shell command to be executed
#ttt# > $tell tell the world what we're starting (boolean)
#ttt# > $timeo max time (secs) to wait for command output
#ttt# > $online arguments to be passed to &ttt_read_agents
#ttt# > $oneof (see above)
#ttt# > $ontimeo "" ""
#ttt# > $as argument to ttt_start_agent
#ttt# > $ltimeo argument to ttt_read_agents
#ttt# > $checkRbits "" ""
#ttt# > $mode "" ""
#ttt# > $name argument to ttt_start_agent
#ttt# < $status the exit status of the command
#ttt# < $output the output (stdout + stderr) of the command;
#ttt# will be valid if $online is undef
#ttt#
#ttt# This routine can be used to run a command on a test target system.
#ttt# It's intended for situations where you just want run a single shell
#ttt# command, and aren't interested in demultiplexing or interpreting the
#ttt# output (at least, within ttt_rexec())
#ttt#
#ttt# Only the $hostname and $cmd arguments are mandatory; the remaining
#ttt# arguments can be elided (or passed as "undef"), to get the following
#ttt# defaults:
#ttt#
#ttt# $tell 1 (true)
#ttt# $timeo (default value in ttt_read_agents())
#ttt# $online (default value in ttt_read_agents())
#ttt# $oneof (default value in ttt_read_agents())
#ttt# $ontimeo (default value in ttt_read_agents())
#ttt# $as (default value in ttt_start_agent())
#ttt# $ltimeo (default value in ttt_read_agents())
#ttt# $checkRbits (default value in ttt_read_agents())
#ttt# $mode (default value in ttt_read_agents())
#ttt#
sub ttt_rexec
{
local ($hostname, $cmd, $tell, $timeo, $online, $oneof, $ontimeo, $as,
$ltimeo, $checkRbits, $mode, $name) = @_;
local ($agentid, $rbits, $status);
local ($output) = "";
if (ref($_[0]) eq "HASH") # all parameters passed in a hash instead of a list
{
$hostname = ${$_[0]}{hostname};
$cmd = ${$_[0]}{cmd};
$tell = ${$_[0]}{"tell"};
$timeo = ${$_[0]}{timeo};
$online = ${$_[0]}{online};
$oneof = ${$_[0]}{oneof};
$ontimeo = ${$_[0]}{ontimeo};
$as = ${$_[0]}{as};
$ltimeo = ${$_[0]}{ltimeo};
$checkRbits = ${$_[0]}{checkRbits};
$mode = ${$_[0]}{mode};
$name = ${$_[0]}{name};
}
if (! defined($online))
{ $online="&ttt_msg(\$agents{\$agentid,\"name\"}, \"\$stream: \$line\"); \$output .= \$line"; }
if (! defined($tell)) { $tell = 1; }
if (! defined($ltimeo)) { $ltimeo = $timeo; }
$agentid = &ttt_start_agent($hostname, $cmd, $tell, $as, $name);
$rbits = $agents{$agentid,"STDOUTt"} | $agents{$agentid,"STDERRt"};
($rbits, @ret) =
&ttt_read_agents($rbits, $timeo, $online, $oneof, $ontimeo,
undef, undef, undef, undef, $ltimeo, $checkRbits, $mode);
if ($#ret == 0 && $ret[0] == 0)
{
# It timed out - kill it! kill it!
# (May want to try SIGTERM first to be polite some day!)
#
&ttt_kill_agents("KILL", $agentid);
$status = 1;
}
$status |= &ttt_close_agent($agentid);
if ($output ne "")
{ return ($status, $output); }
else
{ return ($status); }
}
#ttt# ($status[, $output]) = &ttt_rexec_windows($unixhostname, $windowshostname, $cmd,
#ttt# [$tell, [$timeo, [$online, [$oneof, [$ontimeo, [$as,
#ttt# [$ltimeo, [$checkRbits, [$mode, [$name]]]]]]]]]]);
#ttt#
#ttt# ($status[, $output]) = &ttt_rexec_windows(\%params);
#ttt#
#ttt# > \%params reference to a hash which specifies the parameters by name
#ttt#
#ttt# > $unixhostname the name of the UNIX host which r-shells to the windows machine
#ttt# > $windowshostname the name of the Windows host which executes the command
#ttt# > $cmd is a shell command to be executed
#ttt# > $tell tell the world what we're starting (boolean)
#ttt# > $timeo max time (secs) to wait for command output
#ttt# > $online arguments to be passed to &ttt_read_agents
#ttt# > $oneof (see above)
#ttt# > $ontimeo "" ""
#ttt# > $as argument to ttt_start_agent
#ttt# > $ltimeo argument to ttt_read_agents
#ttt# > $checkRbits "" ""
#ttt# > $mode "" ""
#ttt# > $name argument to ttt_start_agent
#ttt# < $status the exit status of the command
#ttt# < $output the output (stdout + stderr) of the command;
#ttt# will be valid if $online is undef
#ttt#
#ttt# This routine can be used to run a command on a windows test system via a path
#ttt# through a UNIX host. This routine is very similar to ttt_rexec (above),
#ttt# so what Richard put there applies here.
#ttt#
#ttt# The windows machine must have a RSHD on it.
#ttt#
#ttt# Currently, the windows machine must have SPAWNER.EXE in it's C:\TTT directory.
#ttt#
#ttt# Only the $unixhostname, $windowshostname, and $cmd arguments are mandatory; the remaining
#ttt# arguments can be elided (or passed as "undef"), to get the following
#ttt# defaults:
#ttt#
#ttt# $tell 1 (true)
#ttt# $timeo (default value in ttt_read_agents())
#ttt# $online (default value in ttt_read_agents())
#ttt# $oneof (default value in ttt_read_agents())
#ttt# $ontimeo (default value in ttt_read_agents())
#ttt#
sub ttt_rexec_windows
{
local ($unixhostname, $windowshostname, $cmd, $tell, $timeo, $online, $oneof,
$ontimeo, $as, $ltimeo, $checkRbits, $mode, $name) = @_;
local (%param_hash);
local ($status);
local ($output) = "";
if (ref($_[0]) eq "HASH") # parameters passed in a hash
{
my ($key,$value);
# first copy the whole hash
while (($key,$value) = each %{$_[0]}) { $param_hash{$key} = $value; }
$param_hash{hostname} = $param_hash{unixhostname};
$param_hash{cmd} = "rsh " . $param_hash{windowshostname} . " '<[DOS]>' C:\\\\TTT\\\\SPAWNER.EXE " . $param_hash{cmd};
delete $param_hash{unixhostname};
delete $param_hash{windowshostname};
($status, $output) =
&ttt_rexec(\%param_hash);
}
else # params passed as a list (normal), so cut up the list and use it the way we want
{
($status, $output) =
&ttt_rexec($unixhostname, "rsh $windowshostname '<[DOS]>' C:\\\\TTT\\\\SPAWNER.EXE $cmd", @_[3..$#_]);
}
if($output eq "") # we should always have output
{
&ttt_msg("error","no output from ttt_rexec_windows\n");
return(-1);
}
# split the output into separate lines, then find the SPAWNER return code
@lines = split(/\n+/,$output);
for($index = 0; $index <= $#lines; $index++)
{
if($lines[$index] =~ /\*SPAWNER\*:(.+)$/)
{
$status = $1;
# $index = $#lines + 1; # this assumes that *SPAWNER*:x is always the last line we care about
}
else # build a list of lines that come before the return code
{
@outputlines = (@outputlines,$lines[$index]);
}
}
$output = join("\n",@outputlines); # join the lines back into a string
return($status,$output);
}
#ttt# $status = &ttt_rprog($hostname, $path, $args, [$tell, [$timeo, [$online,
#ttt# [$oneof, [$ontimeo, [$as, [$ltimeo, [$checkRbits,
#ttt# [$mode, [$name]]]]]]]]]]);
#ttt#
#ttt# $status = &ttt_rprog(\%params);
#ttt#
#ttt# > \%params reference to a hash which specifies the parameters by name
#ttt#
#ttt# > $hostname the name of the host on which run the process
#ttt# > $path pathname (on the controller) to the script
#ttt# > $args arguments to be passed to the script
#ttt# > $tell tell the world what we're starting (boolean)
#ttt# > $timeo max time (secs) to wait for command output
#ttt# > $online arguments to be passed to &ttt_read_agents
#ttt# > $oneof (see above)
#ttt# > $ontimeo
#ttt# > $as
#ttt# > $ltimeo argument to ttt_read_agents
#ttt# > $checkRbits "" ""
#ttt# > $mode "" ""
#ttt# > $name argument to ttt_start_agent
#ttt# < $status the exit status of the command
#ttt#
#ttt# Copies a program from the ttt controller to a ttt target, executes it,
#ttt# then removes it. This was initially created in order to assist with
#ttt# administrative tasks to be done on the target systems, since it is
#ttt# easier to develop and debug such scripts on a target system, and they
#ttt# run faster than if individual commands were to be coded as &ttt_rexec()
#ttt# calls.
#ttt#
#ttt# Note that the script is copied using the uid of the user running the
#ttt# perl program, but the "$as" parameter is honored when the script is
#ttt# run on the remote host.
#ttt#
sub ttt_rprog
{
local ($hostname, $path, $args, $tell, $timeo, $online, $oneof, $ontimeo, $as,
$ltimeo, $checkRbits, $mode, $name) = @_;
local ($progname, $rpath, $status);
if (ref($_[0]) eq "HASH") # all parameters passed in a hash instead of a list
{
$hostname = ${$_[0]}{hostname};
$path = ${$_[0]}{path};
$args = ${$_[0]}{args};
$tell = ${$_[0]}{"tell"};
$timeo = ${$_[0]}{timeo};
$online = ${$_[0]}{online};
$oneof = ${$_[0]}{oneof};
$ontimeo = ${$_[0]}{ontimeo};
$as = ${$_[0]}{as};
$ltimeo = ${$_[0]}{ltimeo};
$checkRbits = ${$_[0]}{checkRbits};
$mode = ${$_[0]}{mode};
$name = ${$_[0]}{name};
}
($progname = $path) =~ s%^.*/%%;
$rpath = "/tmp/$progname.$myhostname.$$";
($status) = &ttt_rexec ($myhostname, "rcp $path $hostname:$rpath",
undef, undef, undef, "");
if ($status != 0)
{
&ttt_msg(STDERR, "error",
"ttt_rprog(): can't copy program to remote host\n");
return ($status);
}
($status) = &ttt_rexec($hostname, "$rpath $args", $tell, $timeo, $online,
$oneof, $ontimeo, $as, $ltimeo, $checkRbits, $mode, $name);
&ttt_rexec($hostname, "rm $rpath",
$tell, $timeo, $online, $oneof, $ontimeo);
return ($status);
}
sub ttt_send_agent
{
local ($agentid, $msg, $localftp) = @_;
local ($stdin_h) = $agents{$agentid, "STDIN"};
&ttt_msg($agents{$agentid,"name"}, "STDIN> $msg");
&ttt_msg($stdin_h, "-q", $msg);
if ($localftp) { &ttt_msg($stdin_h, "", "quote XXXX\n"); }
}
#ttt#
#ttt# ($rbits, [$matched, $expline]) =
#ttt# &ttt_int_agent($agentid, $rbits, $send, $expect[, $nixpect, [$timeo[, $partial[, $localftp]]]]);
#ttt#
#ttt# > $agentid the agent id of the agent to talk to
#ttt# > $rbits the rbits for this agent
#ttt# > $send string to write to the agent's stdin
#ttt# > $expect regexp to wait for from the agent
#ttt# > $nixpect regexp, which if seen, is a fail (not applicable w/$localftp)
#ttt# > $timeo the out interval
#ttt# > $partial whether the agent can send partial line output
#ttt# > $localftp is this a "client local" command to an ftp?
#ttt# < $rbits possibly (if an eof seen) revised $rbits value
#ttt# < $matched boolean; true if the $expect regexp was seen
#ttt# < $expline line that matched $expect
#ttt#
#ttt# This routine is used by a test that needs to interact with an agent on
#ttt# a line-line basis. Since ttt_read_agents() can return before the agent
#ttt# has terminated or returned eof on both descriptors, the possibly
#ttt# modified (if an eof -was- seen) $rbits is passed back to the caller.
#ttt#
#ttt# The $send string is sent to the agent's stdin. If it is
#ttt# undefined or null, no string is sent. The string must contain a
#ttt# leading "<", or ">". If it has the leading "<", then the $send
#ttt# string is sent immediately, and then ttt_int_agent begins
#ttt# scanning for the $expect pattern. If $send has the leading ">",
#ttt# then the $send string is sent only after (and only if) the
#ttt# $expect pattern (typically, a prompt) has been seen.
#ttt#
#ttt# The $expect string is a regular expression; the agents output is
#ttt# monitored, and if it is seen before the timeout expires, the $matched
#ttt# returns true and $expline passes the string that matched back to the
#ttt# caller. If $expect is undefined, then the $send string (which must be
#ttt# of the "<..." form) is sent, and then &ttt_int_agent returns ($rbits)
#ttt# immediately.
#ttt#
#ttt# The special boolean $localftp is provided to allow a workaround for
#ttt# the unfortunate fact that ftp (when run as an agent, no tty), buffers
#ttt# all of its output between the outputs of "-v" messages from the
#ttt# remote server. When $localftp is set, the $send string is followed by
#ttt# a "quote xxxx\n", used to force a response from the server, and thus
#ttt# to flush the client's stdout. The "500 'X": command not understood."
#ttt# response to the "cd .\n" is -not- output (unlike all other messages
#ttt# read from the agent).
#ttt#
sub ttt_int_agent
{
local ($agentid, $rbits, $send, $expect, $nixpect, $timeo, $partial, $localftp) = @_;
local ($stdin_h) = $agents{$agentid, "STDIN"};
local ($expline, $ontimeo, $matched);
#&ttt_msg("DEBUG","&ttt_int_agent\n");
if ($partial && $localftp)
{
&ttt_msg(STDERR, "error",
"ttt_int_agent(): both \$localftp and \$partial?\n");
return($rbits, 0);
}
# Set the overall timeout time
#
if (defined($timeo))
{ $expectimeo = $timeo; } else { $timeo = $expectimeo = 200; }
# Set the ttt_readline_agents timeout time. We use "1" if partial is
# set, otherwise, its the same as $expectimeo
#
if ($partial) { $timeo = 1; }
if ($send =~ /^</)
{ $send =~ s/^<//; &ttt_send_agent($agentid, $send, $localftp); }
if (! defined $expect) { return($rbits); }
if ($localftp)
{
# For the localftp case, we know that $partial is false, so we can
# use this older approach, where the matching is done in our passed
# $online...
#
$online = <<EOS;
if (\$localftp && (\$line =~ /^500 .*XXXX/))
{ last reader; }
if (! (\$line =~ /^500 .*XXXX/))
{ &ttt_msg(\$agents{\$agentid,\"name\"}, "\$stream: \$line"); }
if (\$expect ne "" && \$line =~ /\$expect/)
{
\$matched = 1; \$expline = \$line;
if (! \$localftp) { last reader; }
}
EOS
$ontimeo="&ttt_msg(\" \", \"timeout\n\"); \$matched=0; last reader";
$matched = 0;
$rbits = &ttt_read_agents($rbits, $timeo, $online, undef, $ontimeo);
}
else
{
# For non localftp cases, $partial may be true, so we use the newer
# expectre feature of ttt_read_agents, and let it do the dirtywork
# in its usual inimicable fashion...
#
#&ttt_msg("DEBUG", "&ttt_read_agents expect <$expect> nixpect <$nixpect>\n");
#if (defined($nixpect))
# { &ttt_msg("DEBUG", "nixpect defined\n"); }
#else
# { &ttt_msg("DEBUG", "nixpect undefined\n"); }
($rbits, $matched, $expline)
= &ttt_read_agents
($rbits, $timeo, undef, undef, undef, 0, $partial, $expect, $nixpect, $expectimeo);
}
if ($send =~ /^>/ && $matched)
{ $send =~ s/^>//; &ttt_send_agent($agentid, $send, $localftp); }
return($rbits, $matched, $expline);
}
#ttt# $status =
#ttt# &ttt_system($host, $cmd[, $timeo[, $online[, $oneof[, $ontimeo]]]]);
#ttt#
#ttt# > $host The host to execute $cmd on
#ttt# > $cmd The command to execute
#ttt# > $timeo ... $ontimo Args for &ttt_read_agents()
#ttt# < $status The exit status of $cmd
#ttt#
#ttt# Use this to execute a command on some host. Pass in args for $timeo,
#ttt# $online, $oneof, and $ontimeo to override the defaults provided by
#ttt# &ttt_read_agents. Thus, by default, the command output will be logged;
#ttt# but if you want to examine it, you should override the default by
#ttt# defining $online to do what you want. Uses private $rbits, so it
#ttt# doesn't interact with any other agents.
#ttt#
sub ttt_system
{
local ($host, $cmd, $timeo, $online, $oneof, $ontimeo) = @_;
local ($status, $rbits);
$id = &ttt_start_agent($host, $cmd, 1);
$rbits = $agents{$id,"STDOUTt"} | $agents{$id,"STDERRt"};
&ttt_read_agents($rbits, $timeo, $online, $oneof, $ontimeo);
$status = &ttt_close_agent($id);
return $status;
}
sub ttt_kill_agents
{
my ($sig, @pids) = @_;
my $pid;
my $pids;
foreach $pid (@pids)
{
if (defined($agents{$pid,"onKill"})) # take special action
{
my $onKill = $agents{$pid,"onKill"};
my $tmpMsg = "to kill $pid";
if (defined($agents{$pid,"name"}) and $agents{$pid,"name"} ne $pid)
{
$tmpMsg .= "(". $agents{$pid,"name"} . ")";
}
$tmpMsg .= ":\n$onKill\n";
&ttt_msg("kill",$tmpMsg);
eval $onKill;
if ($@ ne "") { &ttt_msg("evalerr", "$@\n"); }
next;
}
elsif ($agents{$pid,"stattag"} =~ /remote/)
{
# this was remotely executed, kill the child pid as well
my $stattag = $agents{$pid,"stattag"};
my ($host) = ($stattag =~ /[0-9]+:.+:(.+)/);
my ($new_sig) = ($sig =~ /-(.+)/);
my $remote_PID = $agents{$pid,"cmdPID"};
my ($as) = $agents{$pid,"as"};
if (defined($remote_PID))
{
&ttt_rexec(
$host, "kill -$sig $remote_PID", undef,
undef, undef, undef, $as
);
}
}
if (defined($pids)) { $pids .= ", "; }
$pids .= $pid;
if (defined($agents{$pid,"name"}) and $agents{$pid,"name"} ne $pid)
{
$pids .= "(" . $agents{$pid,"name"} . ")";
}
}
if (defined($pids)) { &ttt_msg("kill", "kill $sig $pids\n"); }
kill $sig, @pids;
}
#ttt# ($status, $output) =
#ttt# &ttt_xorbust($host, $cmd[, $buststatus]);
#ttt#
#ttt# > $host The host to execute $cmd on
#ttt# > $cmd The command to execute
#ttt# > $buststatus The exist status (if command fails)
#ttt# < $output The output from $cmd
#ttt#
#ttt# Use this to execute a command on some host, and exit the test
#ttt# driver if the command fails (nonzero exist status). This is
#ttt# typically used for setting up preconditions to actually running
#ttt# test cases, i.e., the failure typically results in a notest
#ttt# exit from the driver.
#ttt#
sub ttt_xorbust
{
local($onhost, $cmd, $buststatus) = @_;
local($output);
if (! defined($buststatus)) { $buststatus = "notest"; }
($status, $output) = &ttt_rexec($onhost, $cmd);
if ($status) { &ttt_exit($buststatus); }
return ($output);
}
###########################################################################
#
# case_* functions
#
# These are utilities for doing send/expect-style test cases...
#
# They all support the notion of a "$status" argument, that can
# maintain state helping to decide whther to really try and run given
# sequence of cases, where later ones are dependent on the success of
# earlier ones.
#
# In general, $status == 0 means all OK;
# $status > 0 means an error;
# and $status == -1 indicates we are in "case skipping" mode.
sub case_expect
{
my ($case, $status, $agentid, $rbits, $send, $want, $wantnot, $timeo, $partial) = @_;
if (defined($case) and ($case eq "")) { undef $case; }
if (!defined($partial)) { $partial = 1; }
if (defined($case)) { &ttt_begin_case($case, 1); }
if ($status != 0)
{
if (defined($case)) { &ttt_end_case("notest"); }
return($rbits, -1);
}
($rbits, $matched, $matchedline)
= &ttt_int_agent($agentid, $rbits, $send, $want, $wantnot, $timeo, $partial);
if ($matched <= 0)
{
if (defined($case)) { &ttt_end_case("fail"); }
return($rbits, 1, $matchedline);
}
if (defined($case)) { &ttt_end_case("pass"); }
return($rbits, 0, $matchedline);
}
sub case_exec
{
my ($case, $status, $host, $cmd, $timeo, $cmpto) = @_;
my $exstat;
my $online;
&ttt_begin_case($case, 1);
#&ttt_msg("DEBUG", "case_exec(): status <$status>\n");
if ($status != 0)
{
&ttt_end_case("notest");
return($rbits, -1);
}
if (defined($cmpto))
{
$online = "\$Output .= \$line; &ttt_msg(\$agents{\$agentid,\"name\"}, \"\$stream: \$line\")";
$Output = "";
}
$exstat = &ttt_system($host, $cmd, $timeo, $online);
#$lll = length($cmpto); &ttt_msg("DEBUG", "case_exec(): cmpto [$lll] <$cmpto>\n");
#$lll = length($Output); &ttt_msg("DEBUG", "case_exec(): Output [$lll] <$Output>\n");
#&ttt_msg("DEBUG", "case_exec(): exstat <$exstat>\n");
if (defined($cmpto))
{
if ($Output ne $cmpto)
{
#&ttt_msg("DEBUG", "case_exec(): mismatch\n");
&ttt_end_case("fail"); return(1);
}
}
elsif ($exstat != 0)
{
#&ttt_msg("DEBUG", "case_exec(): nonzero exit\n");
&ttt_end_case("fail"); return($exstat);
}
&ttt_end_case("pass");
return(0);
}
sub case_eval
{
my ($case, $status, $code) = @_;
my $evalstat;
&ttt_begin_case($case, 1);
if ($status != 0)
{
&ttt_end_case("notest");
return($rbits, -1);
}
#&ttt_msg("DEBUG", "code <$code>\n");
$evalstat = eval $code;
#&ttt_msg("DEBUG", "\$@ <$@>\n");
if (! $evalstat)
{
&ttt_end_case("fail");
return($evalstat);
}
&ttt_end_case("pass");
return(0);
}
$_s_ = "\000";
sub cases_script
{
my ($rbits, $agentid, $status, $def_timeout, @cases) = @_;
my $name;
my $prompt;
my $response;
my ($matched) = 0;
my $matchedline;
my $send;
my $case_timeout;
if (! defined($def_timeout)) { $def_timeout = 60; }
if ($status != 0) { goto notest_remaining; }
while ($#cases >= 0)
{
$case = shift @cases;
($name, $prompt, $response, $case_timeout) = split(/$_s_/, $case);
if (! defined($case_timeout)) { $case_timeout = $def_timeout; }
&ttt_begin_case($name, 1);
if ($response ne "") { $send = ">$response"; } else { $send = ""; }
($rbits, $matched, $matchedline)
= &ttt_int_agent($agentid, $rbits, $send, $prompt, undef, $case_timeout, 1);
if ($matched)
{ &ttt_end_case("pass"); } else { &ttt_end_case("fail"); last; }
}
notest_remaining: 1;
# Notest any remaining cases...
#
while ($#cases >= 0)
{
$case = shift(@cases);
($name, $prompt, $response) = split(/$_s_/, $case);
&ttt_begin_case($name);
&ttt_end_case("notest");
}
# (We return "$status", which is "$matched" inverted)
#
if ($matched) { $status = 0; } else { $status = 1; }
return ($rbits, $status, $matchedline);
}
1;