gecko-dev/mstone/bin/reduce.pl

1059 строки
36 KiB
Perl

# The contents of this file are subject to the Netscape Public
# License Version 1.1 (the "License"); you may not use this file
# except in compliance with the License. You may obtain a copy of
# the License at http://www.mozilla.org/NPL/
#
# Software distributed under the License is distributed on an "AS
# IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
# implied. See the License for the specific language governing
# rights and limitations under the License.
#
# The Original Code is the Netscape Mailstone utility,
# released March 17, 2000.
#
# The Initial Developer of the Original Code is Netscape
# Communications Corporation. Portions created by Netscape are
# Copyright (C) 1997-2000 Netscape Communications Corporation. All
# Rights Reserved.
#
# Contributor(s): Dan Christian <robodan@netscape.com>
# Marcel DePaolis <marcel@netcape.com>
#
# Alternatively, the contents of this file may be used under the
# terms of the GNU Public License (the "GPL"), in which case the
# provisions of the GPL are applicable instead of those above.
# If you wish to allow use of your version of this file only
# under the terms of the GPL and not to allow others to use your
# version of this file under the NPL, indicate your decision by
# deleting the provisions above and replace them with the notice
# and other provisions required by the GPL. If you do not delete
# the provisions above, a recipient may use your version of this
# file under either the NPL or the GPL.
#####################################################
# for each protocol, store rate over time (figure derivative), and final count
# commands
# readMessages
# writeMessages
# readBytes
# writeBytes
# connections
# these are already 0 based over time, and average
# connectDelay
# transactionTime
#require "perl-5.005";
#use Cwd;
print "Combining client results:\t", scalar (localtime), "\n";
# Basic sanity check
unless ($testsecs > 0) {
die "Test time is 0!\n";
}
$startTime = 0; # these are timeInSeconds/$timeStep
$endTime = 0;
# keep graphs with somewhat more precision than sample rate
# this is supposed to help deal with time skew between clients
#$timeStep = int ($params{FREQUENCY} / 2);
#if ($timeStep < 1) { $timeStep = 1; }
$timeStep = int ($params{FREQUENCY});
# global results initialization
$reportingClients = 0;
$totalProcs = 0; # number of clients started
my $maxTimeStep = $params{FREQUENCY}*2;
$maxTimeStep = 10 if ($maxTimeStep < 10);
# Fill in graph values
# Usage: updateGraph (graph, lastTimeStep, TimeStep, timeSecs,
# lastValue, value);
sub updateGraph {
#SLOW: my ($gp, $lastTime, $time, $timeD, $lastValue, $value) = @_;
my $gp = shift; # gp: graph hash to fill in over time
my $lastTime = shift; # lastTime: time values (already divided by timestep)
my $time = shift;
my $timeD = shift; # timeD: time delta in seconds
my $lastValue = shift;
my $value = shift;
return unless ($timeD); # initial case
#print "updateGraph: time='$time' timeD='$timeD' lastValue='$lastValue' value='$value'\n";
my $v = ($value - $lastValue) / $timeD; # figure update / step
for ($i = $lastTime; $i < $time; $i++) { # fill in graph
$gp->{$i} += $v;
}
}
# Fill in graph values, figuring the MIN
# Usage: updateMinGraph (graph, lastTimeStep, TimeStep, value);
sub updateMinGraph {
my $gp = shift; # graph hash to fill in over time
my $lastTime = shift; # time values (already divided by timestep)
my $time = shift;
my $v = shift;
return unless ($lastTime); # initial case
return unless ($v > 0); # 0 min is considered no information
#print "updateMinGraph: time='$time' lastTime='$lastTime' value='$v'\n";
for ($i = $lastTime; $i < $time; $i++) { # fill in graph
$gp->{$i} = $v if (!($gp->{$i}));
$gp->{$i} = $v if ($v < $gp->{$i});
}
}
# Fill in graph values, figuring the MAX
# Usage: updateMaxGraph (graph, lastTimeStep, TimeStep, value);
sub updateMaxGraph {
my $gp = shift; # graph hash to fill in over time
my $lastTime = shift; # time values (already divided by timestep)
my $time = shift;
my $v = shift;
return unless ($lastTime); # initial case
#print "updateMaxGraph: time='$time' lastTime='$lastTime' value='$v'\n";
for ($i = $lastTime; $i < $time; $i++) { # fill in graph
$gp->{$i} = $v if (!($gp->{$i}));
$gp->{$i} = $v if ($v > $gp->{$i});
}
}
# Turn one of the disadvantages of interpreted code to an advantage
# by writing optimal code on the fly.
# You must be taller than Kenny the kangaroo to edit this code.
# Create a function that will parse timers (all timer must be identical)
# Timer are built out of positional assignments (not attr=value pairs)
sub CreateFastTimerParser {
my $ltype = shift; # hash of line parsing info
my $fstr = shift; # format string
my @tlist = @{$ltype->{"$fstr:SEPS"}};
my @nlist = @{$ltype->{"$fstr:NAMES"}};
# function preamble
my $fn = "sub FastTimerParser {\n";
$fn .= 'my $sc = shift; my $gp = shift;
my $lt = shift; my $t = shift; my $td = shift;
my $ltype = shift; my $fstr = shift;
my $ln = shift;' . "\n";
#$fn .= 'print "(fastTimerParser) $fstr $lt $t $td\n";' . "\n";
$fn .= 'if ($ln =~ m/^';
foreach $s (@tlist) { # write pattern match
$fn .= "(.+)$s";
}
$fn .= '(.+)$/) {' . "\n"; # last field in match
#$fn .= 'print "$ln =\t$1 + $2 / $3 + $4 / $5 [ $6 , $7 ] $8\n";' . "\n";
my $n = 0;
foreach $v (@nlist) { # write update calls
$n++;
if ($v =~ /Min$/) {
$fn .= 'updateMinGraph ($gp->{"' . $v . '"}, $lt, $t, $' . $n . ");\n";
# Handle never defined case first.
$fn .= '$sc->{"' . $v . '"} = 0 if (!($sc->{"' . $v . '"}));' . "\n";
# Do the Min update. 0 is not a valid number
$fn .= '$sc->{"' . $v . '"} = $' . $n . ' if (($' . $n . ' > 0) && (($sc->{"' . $v . '"} == 0) || ($' . $n . ' < $sc->{"' . $v . '"})));' . "\n";
} elsif ($v =~ /Max$/) {
$fn .= 'updateMaxGraph ($gp->{"' . $v . '"}, $lt, $t, $' . $n . ");\n";
$fn .= '$sc->{"' . $v . '"} = $' . $n . ' if (!($sc->{"' . $v . '"}) || ($' . $n . ' > $sc->{"' . $v . '"}));' . "\n";
} else {
$fn .= 'updateGraph ($gp->{"' . $v . '"}, $lt, $t, $td, $sc->{"' . $v . '"}, $' . $n . ");\n";
$fn .= '$sc->{"' . $v . '"} = $' . $n . ";\n";
}
}
$fn .= "\n} else {\n";
$fn .= 'die "Error parsing timer from: $ln\n";';
$fn .= "\n}\n}\n";
#($params{DEBUG}) && print "Created timer parse function: $fn\n";
eval $fn; # create the function
$timerParser = \&FastTimerParser;
}
# All this quoted stuff will screw up Emacs' formatter/colorizer. Oh well.
# Similar to above.
# This seems to be a smaller gain (about 10%) than the timers.
sub CreateFastProtocolParser {
my $ltype = shift; # hash of line parsing info
my $fstr = shift; # format string
my @tlist = @{$ltype->{"$fstr:SEPS"}};
my @nlist = @{$lst = $ltype->{"$fstr:NAMES"}};
#print "CreateFastProtocolParser: $fstr\n";
my $nm = $fstr;
$nm =~ s/^.*://;
my $fn = "sub FastProtocolParser$nm {\n";
$fn .= 'my $sc = shift; my $gp = shift;
my $lt = shift; my $t = shift; my $td = shift;
my $ltype = shift; my $fstr = shift;
my $ln = shift;' . "\n";
#$fn .= 'print "(FastProtocolParser' . $nm . ' ) $fstr $lt $t $td\n";' . "\n";
$fn .= 'if ($ln =~ m/^';
my $posttext = pop @tlist; # save last bit of text
foreach $s (@tlist) { # write pattern match
$fn .= "$s(.+)";
}
$fn .= $posttext . '$/) {' . "\n"; # last text in match
my $n = 0;
foreach $v (@nlist) { # write update calls
$n++;
if ($v =~ m/^\[(.+)\]$/) { # timer
$fn .= 'FastTimerParser ($sc->{"' . $1 . '"}, $gp->{"' . $1 . '"}, $lt, $t, $td, $ltype, "TIMERS:' . $1 . '", $' . $n . ');' . "\n";
} else { # direct assignment
$fn .= 'updateGraph ($gp->{"' . $v . '"}, $lt, $t, $td, $sc->{"' . $v . '"}, $' . $n . ');' . "\n";
$fn .= '$sc->{"' . $v . '"} = $' . $n . ";\n";
}
}
$fn .= "\n} else {\n";
$fn .= 'die "Error parsing protocol ' . $nm . ' from: $ln\n";';
$fn .= "\n}\n}\n";
$fn .= '$cliLines{"SUMMARY-TIME"}->{"' . $fstr . ':PROTOPARSE"} = \&FastProtocolParser' . $nm . ";\n";
#print "Created proto parse function: $fn\n";
eval $fn; # create the function
}
# This is the slow verson of timer parsing. Kept for possible debugging
# There are only 4 levels to the parse hierarchy: line, protocol, timer, value
# each level consists of 1 or more elements from lower levels, plus text
# Given a timer format description, break string into name,value chunks
# Timer are built out of positional assignments (not attr=value pairs)
# Usage: parseTimer (...lineHash, format, line)
sub parseTimer {
my $subcli = shift; # client hash to update
my $gp = shift; # graph hash to fill in over time
my $lastTime = shift; # time values (already divided by timestep)
my $time = shift;
my $timeD = shift;
my $ltype = shift; # hash of line parsing info
my $fstr = shift; # format string
my $line = shift # text line
|| die "Missing arguments to parseTimer";
my @tlist = @{$ltype->{"$fstr:SEPS"}};
my @nlist = @{$lst = $ltype->{"$fstr:NAMES"}};
#print "\nTimer seps ($fstr): @tlist\nNames: @nlist\n";
my $remln = $line;
while (@nlist) {
my $chunk;
my $sepln;
my $posttext = shift @tlist;
my $vname = shift @nlist;
if ($posttext) { # remln looks like <value><literal text>...
($chunk, ($sepln), $remln) = split /($posttext)/, $remln, 2;
#print "chunk='$chunk' sep='$sepln' remln='$remln'\n";
die "Error finding string '$posttext' in '$remln' of '$line'"
unless ($sepln);
} else { # remln looks like <value>
$chunk = $remln;
}
#print "$vname=$chunk ";
die "updateGraph: Missing graph '$vname'\n" unless ($gp->{$vname});
if ($vname =~ /Min$/) {
updateMinGraph ($gp->{$vname}, $lastTime, $time, $chunk);
} elsif ($vname =~ /Max$/) {
updateMaxGraph ($gp->{$vname}, $lastTime, $time, $chunk);
} else {
updateGraph ($gp->{$vname}, $lastTime, $time, $timeD,
$subcli->{$vname}, $chunk);
}
$subcli->{$vname} = $chunk;
}
#print "\n";
}
# This is the slow verson of protocol parsing. Kept for possible debugging
# Given a format description, break string into name,value chunks
# Very similar to parseLine, except: no sub protocols, no top level issues
# Usage: parseProtocol (...lineHash, format, line)
sub parseProtocol {
my $subcli = shift; # client hash to update
my $gp = shift; # graph hash to fill in over time
my $lastTime = shift; # time values (already divided by timestep)
my $time = shift;
my $timeD = shift;
my $ltype = shift; # hash of line parsing info
my $fstr = shift; # format string
my $line = shift # text line
|| die "Missing arguments to parseProtocol";
#print "\nparseProtocol format='$fstr' line='$line'\n";
my @tlist = @{$ltype->{"$fstr:SEPS"}};
my @nlist = @{$lst = $ltype->{"$fstr:NAMES"}};
#print "\nProtocol seps ($fstr): @tlist\nNames: @nlist\n";
# remove first part of literal text
my $posttext = shift @tlist;
my ($chunk, $sepln, $remln) = split /($posttext)/, $line, 2;
die "Error parsing initial string '$posttext' from '$line'"
unless ($sepln);
# progressively split $fstr into literal chunks
# back to back timers or protocols (with no literal space) is not allowed
while (@nlist) {
# remln always looks like <value><literal text>
my $vname = shift @nlist;
$posttext = shift @tlist;
#print "posttext='$posttext'\n";
($chunk, ($sepln), $remln) = split /($posttext)/, $remln, 2;
#print "chunk='$chunk'\n";
#print "remln=$remln\n\n";
die "Error finding string '$posttext' in '$remln'"
unless ($sepln);
if ($vname =~ m/^\[(.+)\]$/) { # timer
#print "TIMER $vname ";
die "Unknown timer referenced: $vname for client "
. $scalar{"client"} . "\n"
unless ($subcli->{$1});
die "Invalid timer specified: $ltype->{TIMERS}->{$vname} in '$line'"
unless ($ltype->{TIMERS}->{$vname});
FastTimerParser ($subcli->{$1}, $gp->{$1},
$lastTime, $time, $timeD,
$ltype, "TIMERS:$1", $chunk);
} else { # direct assignment
#print "$vname='$chunk' ";
die "updateGraph: Missing graph '$vname'\n" unless ($gp->{$vname});
updateGraph ($gp->{$vname}, $lastTime, $time, $timeD,
$subcli->{$vname}, $chunk);
$subcli->{$vname} = $chunk;
}
}
#print "\n";
}
# Given a format description, break string into name,value chunks
# Figures out all the top level issues of:
# Figure out what client, what time span,
# Pass down top level structures
# Do final special processing (connections graph)
# Usage: parseLine (clientsHash, lineHash, format, line)
sub parseLine {
my $clients = shift; # hash of all clients
my $ltype = shift; # hash of line parsing info
my $fstr = shift; # format string to match
my $line = shift # line to parse up
|| die "Missing arguments to parseLine";
#print "parseLine: $line\n"; # format='$fstr'
my %scalar = (); # hold scalars until client storage located
my $subcli; # client hash to update ($clients->{$n})
my $lastTime; # time values (already divided by timestep)
my $time;
my $timeD; # time delta (in seconds)
my @tlist = @{$ltype->{"$fstr:SEPS"}};
my @nlist = @{$lst = $ltype->{"$fstr:NAMES"}};
#print "\nLine seps ($fstr): @tlist\nNames: @nlist\n";
# remove first part of literal text
# This should always work, since we pattern matched on this to get here
my $posttext = shift @tlist;
my $vname;
#print "posttext='$posttext'";
my ($chunk, $sepln, $remln) = split /($posttext)/, $line, 2;
die "Error parsing initial string '$posttext' from '$line'"
unless ($sepln);
# progressively split $fstr into literal chunks
while (@nlist) {
# remln always looks like <value><literal text>
$vname = shift @nlist;
$posttext = shift @tlist;
#print "\nposttext='$posttext' vname='$vname'\n";
($chunk, ($sepln), $remln) = split /($posttext)/, $remln, 2;
#print "chunk='$chunk'\n";
#print "remln=$remln\n\n";
die "Error finding string '$posttext' in '$remln'"
unless ($sepln);
if (($vname =~ m/^\[.+\]$/)
|| ($vname =~ m/^\{.+\}$/)){ # timer or hash
unless ($subcli) { # setup sub client
$subcli = $clients->{$scalar{"client"}};
die "Error parsing client number $scalar{client}"
unless ($subcli);
die "Unknown client referenced: $scalar{client}\n"
unless ($subcli);
$time = $scalar{"time"};
if ($subcli->{"time"}) {
$lastTime = $subcli->{"time"};
$timeD = $time - $lastTime; # seconds (not steps)
$lastTime = int ($lastTime / $timeStep); # to timesteps
if (0 == $timeD) { # final summary case
$timeD = 1;
#print "Final update client=$n time=$time\n";
$time += 1; # so 1 data point gets updated
}
} else { # first time report
$subcli->{"startTime"} = $time;
$lastTime = 0;
$timeD = 0; # no time update
}
$time = int ($time / $timeStep); # convert to timesteps
# now store the scalars we have already seen
#print "(";
foreach $k (keys %scalar) {
#print "$k=$scalar{$k} ";
$subcli->{$k} = $scalar{$k};
# Don't bother with time graphs here
}
#print ") ";
}
if ($vname =~ m/^\[(.+)\]$/) { # timer
#print "TIMER $vname '$chunk'\n";
die "Unknown timer referenced: $vname for client $scalar{client}\n"
unless ($subcli->{$1});
die "Invalid timer specified: $ltype->{TIMERS}->{$vname}"
unless ($ltype->{TIMERS}->{$vname});
FastTimerParser ($subcli->{$1}, $graphs{$1},
$lastTime, $time, $timeD,
$ltype, "TIMERS:$1", $chunk);
} elsif ($vname =~ m/^\{(.+)\}$/) { # protocol
#print "PROTOCOL $vname '$chunk'\n";
die "Unknown protocol referenced: $vname for client $scalar{client}\n"
unless ($subcli->{$1});
die "Invalid protocol specified: $ltype->{PROTOCOLS}->{$1}"
unless ($ltype->{PROTOCOLS}->{$vname});
#parseProtocol
&{$ltype->{"PROTOCOLS:$1:PROTOPARSE"}}
($subcli->{$1}, $graphs{$1},
$lastTime, $time, $timeD,
$ltype, "PROTOCOLS:$1", $chunk);
} else {
die "parseLine: Unknown separator $posttext\n";
}
} else { # direct assignment
# Note: we don't graph any scalars at the line level
#print "$vname='$chunk'\n";
$scalar{$vname} = $chunk; # store for later
$subcli->{$k} = $chunk if ($subcli);
}
}
#print "\n";
return unless ($timeD); # skip rest if first sample
# Now do post processing based on the updated $subcli
foreach $prot (@protocols) { # figure concurrent connections
next unless ($subcli->{$prot});
my $pcli = $subcli->{$prot};
next unless (($pcli->{"conn"}) && ($pcli->{"conn"}->{"Try"}));
my $connD = $pcli->{"conn"}->{"Try"}; # connections minus logouts
$connD += $pcli->{"reconn"}->{"Try"} if ($pcli->{"reconn"});
$connD -= $pcli->{"logout"}->{"Try"};
$connD -= $pcli->{"total"}->{"Error"}; # subtract sum of errors
# foreach $k (keys %$pcli) { # subtract errors (which force close)
# ($k =~ /total/) && next;
# $connD -= $pcli->{$k}->{"Error"};
# }
#print "DERIVED connections {$prot}\n";
die "updateGraph: Missing graph 'connections'\n"
unless ($graphs{$prot}->{"connections"});
# pass timeD as 1 to avoid time scaling
updateGraph ($graphs{$prot}->{"connections"},
$lastTime, $time, 1, 0, $connD);
}
}
# Walk a format description (recursively)
# Usage: walkFormatValues (clientHash, formatHash, "LINE", evalExpr)
# Eval expression is call as follows:
# value in $a
# field name in $f
# field path in $p
sub walkFormatValues {
my $cli = shift; # hash of all clients
my $ltype = shift; # hash of line parsing info
my $fstr = shift; # format string to match
my $doit = shift; # routine to call
my $p = shift; # path to variable (may be empty)
#print "walkFormatValues ($fstr): extra: @_\n" if (@_);
my @nlist = @{$ltype->{"$fstr:NAMES"}};
#print "walkFormatValues ($fstr): @nlist";
if ($p) { # initialize path
$p .= ":";
} else {
$p = "";
}
while (@nlist) {
my $f = shift @nlist; # get field name
if ($f =~ m/^\[(.+)\]$/) { # timer
#print "Timer $f:\n";
die "Unknown timer referenced: $f for client $scalar{client}\n"
unless ($cli->{$1});
die "Invalid timer specified: $ltype->{TIMERS}->{$f}"
unless ($ltype->{TIMERS}->{$f});
walkFormatValues ($cli->{$1}, $ltype, "TIMERS:$1",
$doit, "$p$1", @_);
} elsif ($f =~ m/^\{(.+)\}$/) { # protocol
#print "Protocol $f:\n";
die "Unknown protocol referenced: $f for client $scalar{client}\n"
unless ($cli->{$1});
die "Invalid protocol specified: $ltype->{PROTOCOLS}->{$1}"
unless ($ltype->{PROTOCOLS}->{$f});
walkFormatValues ($cli->{$1}, $ltype, "PROTOCOLS:$1",
$doit, "$p$1", @_);
} else { # direct assignment
#print "$p$f=$a ";
#too slow???: eval $doit;
&$doit ($cli->{$f}, $f, $p, @_);
}
}
#print "\n";
}
# Given a timer format description, break string into name,value chunks
# Usage: allocTimer (clientsHash, graphHash, lineHash, format)
sub allocTimerStorage {
my $clients = shift; # hash of this client
my $graphs = shift; # hash of graphs
my $ltype = shift; # hash of line parsing info
my $fstr = shift; # format string to match
my $sepstr = shift; # separator storage to fill in
#print "parseTimer: format='$fstr'\n\tline='$line'\n";
my $sepf;
my $remf = $fstr;
my $chunk;
my $sepln;
my $remln = $line;
my $vname;
my @tlist = (); # list of text tokens
my @nlist = (); # list of names
# progressively split $fstr into literal chunks
while ($remf) {
# remf always looks like <tag><literal text>...
($vname, $sepf, $remf) = split /([][()+\/\,;:|])/, $remf, 2;
if ($remf) { # remln looks like <value><literal text>...
$sepf =~ s/([][{}*+?^.\/])/\\$1/g; # quote regex syntax
# push @tlist, qr/$sepf/; # store compiled match expression
push @tlist, $sepf;
} else { # remln looks like <value>
$chunk = $remln;
}
push @nlist, $vname;
#print "vname='$vname' sep='$sepf'\n";
unless ($graphs->{$vname}) {
#print "$vname ";
# This hash that will hold the actual values over time
$graphs->{$vname} = ArrayInstance->new();
}
}
#print "Timer sep list: @tlist. Names: @nlist\n";
$ltype->{"$sepstr:SEPS"} = \@tlist;
$ltype->{"$sepstr:NAMES"} = \@nlist;
CreateFastTimerParser ($ltype, $sepstr) unless ($timerParser);
# SIDE EFFECT: updates timerFieldsAll
@timerFieldsAll = @nlist unless (@timerFieldsAll);
}
# Walk a format discription and create storage hierarchy
# Also creates the separator and field names lists used everywhere else
# Some way to precompile the regular expressions (perl 5.005)?
# Usage: allocStorage (clientsHash, graphHash, lineHash, format, "LINE")
sub allocStorage {
my $clients = shift; # hash of this client
my $graphs = shift; # hash of graphs
my $ltype = shift; # hash of line parsing info
my $fstr = shift; # format string to match
my $sepstr = shift; # separator storage to fill in
#print "\nallocStorage format='$fstr'\n";
my @tlist = (); # list of text tokens
my @nlist = (); # list of name tokens
# remove first part of literal text
my ($posttext, $sepf, $remf) = split /([=\{\[])/, $fstr, 2;
my $nexttext = $posttext . $sepf;
$posttext .= $sepf if ($sepf =~ m/=/); # should always happen?
push @tlist, $posttext; # store initial text too
# progressively split $fstr
my $vname;
while ($remf) {
my $lasttext = $nexttext; # last literal text goes with this $vname
# Get the variable name
# remf always looks like <tag><literal text>
#$remf =~ s/^(\w+)//; $vname = $1; # strip value text off line
($vname, $sepf, $remf) = split /([^\w])/, $remf, 2; # get value text
unless ($vname) { # got =[ or ={, go again.
#print "+$sepf ";
$nexttext .= $sepf;
next;
}
$remf = $sepf . $remf # put separator back in to remainder
unless ($sepf =~ /[\]\}]/); # unless after a timer/proto name
#print "vname='$vname'\n";
# now get the next bit of literal text
($posttext, $sepf, $remf) = split /([][={}])/, $remf, 2;
$nexttext = $posttext . $sepf if ($remf); # unless end of line
if (($sepf) && ($sepf =~ m/=/)) { # direct assignment
$posttext .= $sepf; # this is part of literal text
}
$posttext =~ s/([][{}*+?^.\/])/\\$1/g; # quote regex syntax
#print "`$lasttext' "; # this shows some trailing cruft, oops
#print "remf='$remf'\n";
# push @tlist, qr/$posttext/; # save separator text
push @tlist, $posttext; # save separator text
if ($lasttext =~ m/[][]/) { # timer
#print "[$vname] ";
push @nlist, "[$vname]"; # save field name as timer
my $nm = "[$vname]";
die "Invalid timer specified: $vname in '$fstr'"
unless ($ltype->{TIMERS}->{$nm});
$clients->{$vname} = ArrayInstance->new(); # create sub hash
unless ($graphs->{$vname}) { # create graph
#print "Creating timer graph '$vname': ";
$graphs->{$vname} = ArrayInstance->new();
} else {
#print "Timer graph '$vname' already exists.";
}
allocTimerStorage ($clients->{$vname}, $graphs->{$vname},
$ltype,
$ltype->{TIMERS}->{$nm}, "TIMERS:$vname");
#print "\n"
} elsif ($lasttext =~ m/[{}]/) { # protocol
#print "{$vname}\n";
push @nlist, "{$vname}"; # save field name as protocol
my $nm = "{$vname}";
$clients->{$vname} = ArrayInstance->new(); # create sub hash
die "Invalid protocol specified: $vname"
unless ($ltype->{PROTOCOLS}->{$nm});
unless ($graphs->{$vname}) { # create graph protocol
#print "Creating graph protocol '$vname'\n";
$graphs->{$vname} = ArrayInstance->new();
# create generated scalar fields
$graphs->{$vname}->{"connections"} = ArrayInstance->new();
}
# recurse into protocol definition
# this would allow recursive protocols,
# but this isn't supported elsewhere
allocStorage ($clients->{$vname}, $graphs->{$vname},
$ltype,
$ltype->{PROTOCOLS}->{$nm}, "PROTOCOLS:$vname");
# SIDE EFFECT: updates protocolFields
unless ($protocolFields{$vname}) {
my $lst = $ltype->{"PROTOCOLS:$vname:NAMES"};
$protocolFields{$vname} = $lst;
#print "$vname fields: @{$lst}\n"; # DEBUG
}
CreateFastProtocolParser ($ltype, "PROTOCOLS:$vname")
unless ($cliLines{"SUMMARY-TIME"}->{"PROTOCOLS:$vname:PROTOPARSE"});
} elsif ($lasttext =~ m/=/) { # direct assignment
#print "$vname ";
push @nlist, $vname; # save field name
#$clients->{$vname} = 0; # preset scalar field
unless ($graphs->{$vname}) { # create graph
#print "Creating value graph '$vname'\n";
$graphs->{$vname} = ArrayInstance->new();
}
} else {
die "Got lost parsing $fstr\n";
}
}
#print "Line/proto sep list: @tlist\nNames: @nlist\n";
$ltype->{"$sepstr:SEPS"} = \@tlist;
$ltype->{"$sepstr:NAMES"} = \@nlist;
}
# These are helper routines to be called by walkFormatValues
# Each gets called at each format node with value, field name, field path
sub walkShowVar {
my $a = shift; my $f = shift; my $p = shift;
print CSV "$p$f,";
}
sub walkShowName {
my $a = shift;
print CSV "$a,";
}
sub walkCreateFinals {
my $a = shift; my $f = shift; my $p = shift;
if ($p =~ /(\w+):(\w+):$/) {
$finals{$1}->{$2}= ArrayInstance->new() unless ($finals{$1}->{$2});
}
}
# Add up client data to form total data
sub walkTotalFinals {
my $a = shift; my $f = shift; my $p = shift;
if ($p =~ /(\w+):(\w+):$/) { # sub arrray case
my $pr = $1; my $tm = $2;
if (!($finals{$pr}->{$tm}->{$f})) { # first assignment
$finals{$pr}->{$tm}->{$f} = $a;
} elsif ($f =~ /Min$/) { # take the new MIN
$finals{$pr}->{$tm}->{$f} = $a
if (($a > 0.0) && ($a < $finals{$pr}->{$tm}->{$f}));
} elsif ($f =~ /Max$/) { # take the new MAX
$finals{$pr}->{$tm}->{$f} = $a if ($a > $finals{$pr}->{$tm}->{$f});
} else { # simple sum
$finals{$pr}->{$tm}->{$f} += $a;
}
} elsif ($p =~ /(\w+):$/) { # scalar case, simple sum
$finals{$1}->{$f} += $a;
}
}
# Since all timers must be the same
#@timerFieldsAll # names of all timer fields (in order)
%protocolFields = (); # protocol as key, hash of lists of fields
# This is where the raw data files get read in.
foreach $section (@workload) {
next unless ($section->{sectionTitle} =~ /CLIENT/o);
next unless ($section->{PROCESSES}); # unused client
my $slist = $section->{sectionParams};
$slist =~ s/HOSTS=\s*//; # strip off initial bit
foreach $cli (split /[\s,]/, $slist) {
my $clientfile= getClientFilename ($cli, $section);
# open the output from this child
open(CLIENTDATA, "<$clientfile") ||
open(CLIENTDATA, "gunzip -c $clientfile.gz |") ||
warn "Couldn't open $clientfile:$!\n";
# start writing clients.csv file
fileBackup ("$resultdir/client-$cli.csv");
open(CSV, ">$resultdir/clients-$cli.csv") # Summary of all clients
|| die "Could not open $resultdir/client-$cli.csv: $!\n";
($params{DEBUG}) && print "Processing $clientfile\n";
($params{DEBUG}) && print "\tInput start:\t", scalar (localtime), "\n";
my $numThisClient=0;
my $linesThisClient=0;
my $skippedLines=0;
my $summaryLines=0;
my $noticeLines=0;
%cliLines = (); # line_name as key, hash of info fields
my %clidata = (); # clear client data store
my $cliTimers = ArrayInstance->new(); # timer, format pairs
my $cliProtocols = ArrayInstance->new(); # protocol, format pairs
# read through, looking for connections and throughput over time
RAWLINE: while (<CLIENTDATA>) {
$linesThisClient++;
if (/^<FORMAT client=/) { # FORMAT definition
#print "FORMAT (raw) $_\n";
s/<\/FORMAT>\s*$//; # strip close format and newline
s/"//; # strip quotes (Fix emacs) "
my ($element, $value) = split />/, $_, 2;
$element =~ s/^<FORMAT //; # strip initial part
my ($clipair, $typepair) = split /\s/, $element;
my ($clijunk, $clinum) = split /=/, $clipair;
my ($type, $label) = split /=/, $typepair;
if ($type =~ /TIMER/) {
unless ($cliTimers->{$label}) { # already exists
$cliTimers->{$label} = $value;
($params{DEBUG}) &&
print "TIMER $label, $value\n";
#print CSV "<FORMAT client=$clinum TIMER=$label>$value</FORMAT>\n";
}
} elsif ($type =~ /PROTOCOL/) {
unless ($cliProtocols->{$label}) {
$cliProtocols->{$label} = $value;
($params{DEBUG}) &&
print "PROTOCOL $label, $value\n";
#print CSV "<FORMAT client=$clinum PROTOCOL=$label>$value</FORMAT>\n";
}
} elsif ($type =~ /LINE/) {
# Note: Line types ($label) must be unique
unless ($cliLines{$label}) { # already seen
my ($spat) = split /=/, $value;
$spat = "^$spat=";
($params{DEBUG}) &&
print "LINE/$spat/ $value\n";
#print "LINE short pattern '^$spat='\n";
# Store all the information about parsing this line
$cliLines{$label} = ArrayInstance->new();
$cliLines{$label}->{LINE} = $value;
# $cliLines{$label}->{PATTERN} = qr/^$spat/;
$cliLines{$label}->{PATTERN} = "^$spat";
$cliLines{$label}->{TIMERS} = $cliTimers;
$cliLines{$label}->{PROTOCOLS} = $cliProtocols;
#print CSV "<FORMAT client=$clinum LINE=$label>$value</FORMAT>\n";
} else {
#print "Skipping already seen line: $label $value\n";
}
# Allocate storage for each client number
unless ($clidata{$clinum}) {
$clidata{$clinum} = ArrayInstance->new();
allocStorage ($clidata{$clinum}, \%graphs,
$cliLines{$label},
$cliLines{$label}->{LINE}, "LINE");
}
} else {
print "Unknown FORMAT: line $_\n";
}
next;
}
# check most common case first
if (/$cliLines{"SUMMARY-TIME"}->{PATTERN}/) {
chomp; # strip newline
parseLine (\%clidata,
$cliLines{"SUMMARY-TIME"}, "LINE", $_);
$summaryLines++;
next;
}
# Should optimize this dynamic matching, Perl Cookbook 182-185
foreach $key (keys %cliLines) {
#print "Checking $cliLines{$key}->{PATTERN}\n";
next unless (m/$cliLines{$key}->{PATTERN}/);
#print "\nMatched dynamic line $key: '$cliLines{$key}->{PATTERN}'\n";
if ($key =~ /^SUMMARY-TIME/) {
warn "SUMMARY-TIME slipped through. Should never happen\n";
} elsif ($key =~ /^NOTICE/) {
$noticeLines++;
next RAWLINE;
} elsif ($key =~ /^BLOCK-STATISTICS-/) {
# ignore for now
next RAWLINE;
} else {
warn "Found format line without hander $key\n";
last;
}
}
($params{DEBUG}) && print "skipping $.: $_";
$skippedLines++;
next;
}
close(CLIENTDATA);
($params{DEBUG}) && print "\tInput done:\t", scalar (localtime), "\n";
my $pcount = $section->{PROCESSES};
my $tcount = ($section->{THREADS}) ? $section->{THREADS} : 1;
$totalProcs += $pcount * $tcount;
# Update totals, and dump out client numbers
my @clist = sort numeric keys %clidata;
$numThisClient = $#clist+1;
$reportingClients += $numThisClient * $tcount;
# Write out format description. Note can be different for every client
walkFormatValues ($clidata{0}, $cliLines{"SUMMARY-TIME"}, "LINE",
\&walkShowVar);
print CSV "\n";
foreach $p (@protocols) { # Create the finals arrays as needed
$finals{$p} = ArrayInstance->new() unless ($finals{$p});
}
# Create finals arrays (if needed)
walkFormatValues ($clidata{0}, $cliLines{"SUMMARY-TIME"}, "LINE",
\&walkCreateFinals);
foreach $cnum (@clist) {
my $cn = $clidata{$cnum};
#print "Total client $cnum\n";
# Total finals array. Handle Min and Max special cases
walkFormatValues ($cn, $cliLines{"SUMMARY-TIME"}, "LINE",
\&walkTotalFinals);
}
($params{DEBUG}) && print "\tTotals done:\t", scalar (localtime), "\n";
foreach $cnum (@clist) {
my $cn = $clidata{$cnum};
# Write out CSV
walkFormatValues ($cn, $cliLines{"SUMMARY-TIME"}, "LINE",
\&walkShowName);
print CSV "\n";
}
($params{DEBUG}) && print "\tCSV done:\t", scalar (localtime), "\n";
#print "\n";
print "Processed: $clientfile: $numThisClient clients\n";
if (1 || $params{DEBUG}) {
foreach $cnum (@clist) {
printf "\tFirst: %d\tFinal: %d\tDuration: %d\n",
$clidata{$cnum}->{startTime}, $clidata{$cnum}->{"time"},
$clidata{$cnum}->{"time"} - $clidata{$cnum}->{startTime};
}
}
print "\t$summaryLines summaries, $noticeLines notices, $skippedLines unknown.\n";
print CSV "\n";
close(CSV);
($params{DEBUG}) && print "Wrote $resultdir/client-$cli.csv\n";
}
}
%cliLines = (); # clear storage
unless ($reportingClients > 0) {
print "No clients reported. Check $resultdir/stderr\n";
die "Test Failed!";
}
# Find time extent for a key graph
($startTime, $endTime) = dataMinMax ("blocks", \@protocols,
$startTime, $endTime);
$realTestSecs = ($endTime - $startTime) * $timeStep;
$realTestSecs = 1 unless ($realTestSecs); # in case of small MaxBlocks
printf "Reported test duration %d seconds with %d second resolution\n",
$realTestSecs, $timeStep;
$realTestSecs = $testsecs if ($realTestSecs > $testsecs);
($params{DEBUG})
&& print "Doing statistical data reduction:\t", scalar (localtime), "\n";
# WRONG: These numbers have already been converted to rate and summed
# Convert Time2 to standard deviation
foreach $p (@protocols) {
my $gp = $graphs{$p};
foreach $n (@{$protocolFields{$p}}) { # all timers
my $t = $n; # don't modify original list
if ($t =~ /^\[(\w+)\]$/) { $t = $1; } # strip off brackets
next unless ($gp->{$t}); # proto doesn't have this timer
my $sp = $gp->{$t}->{"Time2"}; # sum of time squared graph pointer
my $tp = $gp->{$t}->{"Time"}; # sum of time graph pointer
my $np = $gp->{$t}->{"Try"}; # try graph pointer
next unless (($sp) && ($tp) && ($gp));
#print "Calculating std dev $t for $p\n";
foreach $tm (keys %$tp) {
my $n = $np->{$tm};
my $tot = $sp->{$tm};
if ($np->{$tm}) {
my $var = ($sp->{$tm} - (($tot * $tot) / $n)) / $n;
print "$p->$t var < 0: Time2=$sp->{$tm} Time=$tot n=$n \@$tm\n"
if (($var < 0) && ($params{DEBUG}));
$sp->{$tm} = ($var > 0) ? sqrt ($var) : 0.0;
} else {
print "$p->$t: Time2=$sp->{$tm} Time=$tot w/0 tries \@$tm\n"
if (($tp->{$tm}) || ($sp->{$tm})); # internal error check
$sp->{$tm} = 0;
}
}
}
}
($params{DEBUG}) && print "Doing final data reduction:\t", scalar (localtime), "\n";
# divide time graphs by number of tries
foreach $p (@protocols) {
my $gp = $graphs{$p};
foreach $n (@{$protocolFields{$p}}) { # all timers
my $t = $n; # don't modify original list
if ($t =~ /^\[(\w+)\]$/) { $t = $1; } # strip off brackets
next unless ($gp->{$t}); # proto doesn't have this timer
my $tp = $gp->{$t}->{"Time"}; # time graph pointer
my $np = $gp->{$t}->{"Try"}; # try graph pointer
next unless (($tp) && ($gp)); # should never happen.
#print "Ratioing $t for $p\n";
foreach $tm (keys %$tp) {
if ($np->{$tm}) {
$tp->{$tm} /= $np->{$tm} ;
} else {
print "$p->$t: $tp->{$tm} time with 0 tries \@$tm\n"
if ($tp->{$tm}); # internal error check
$tp->{$tm} = 0;
}
}
}
}
print "Saving combined graphs:\t", scalar (localtime), "\n";
# Dump graphs into file by protocol
foreach $p (@protocols) {
my $gp = $graphs{$p};
# Write out data
fileBackup ("$resultdir/time-$p.csv"); # if processing as we go, backup
open(CSV, ">$resultdir/time-$p.csv") # Summary of protocol over time
|| die "Could not open $resultdir/time-$p.csv: $!\n";
print CSV "time";
foreach $t (@{$protocolFields{$p}}) {
if ($t =~ /^\[(\w+)\]$/) { # Timer case, strip off brackets
foreach $f (@timerFieldsAll) {
print CSV ",$p:$1:$f";
}
} else {
print CSV ",$p:$t";
}
}
# note: line print includes initial newline
for (my $tm = $startTime; $tm <= $endTime; $tm++) {
print CSV "\n", $tm-$startTime;
foreach $t (@{$protocolFields{$p}}) {
if ($t =~ /^\[(\w+)\]$/) { # Timer case, strip off brackets
foreach $f (@timerFieldsAll) {
if ($gp->{$1}->{$f}->{$tm}) {
print CSV "," . $gp->{$1}->{$f}->{$tm};
} else {
print CSV ",0";
}
}
} else {
if ($gp->{$t}->{$tm}) {
print CSV "," . $gp->{$t}->{$tm};
} else {
print CSV ",0";
}
}
}
}
print CSV "\n";
close(CSV);
($params{DEBUG}) && print "Wrote $resultdir/time-$p.csv\n";
}
return 1;