\n" ;
exit 0 ;
}
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "3", "Exec Report $FORM{'rptno'} completed");
$OUTPUT_Format = "RTF" ;
print "Content-Type: text/rtf\n";
print "Content-Disposition: attachment;filename=report.rtf\n\n";
&show_template("LAP_Blank_Report_Hank.rtf") ;
$OUTPUT_Format = "HTML" ;
}
################################################################################
#
# Subroutine Name
# GetTestHeader
#
# Description
# This subroutine returns the header of the test file
#
# Inputs
# $clientId -- The id of the client to search through
#
# Outputs
# None
#
# Returns
# @testFields -- An array of fields in the header
#
#adt080401###############################################################################
sub GetTestHeader
{
my $clientId = $_[0];
my @testList = &get_data("tests.$clientId");
my $testHdr = $testList[0];
my $testFields;
chop( $testHdr );
@testFields = split( /&/, $testHdr );
return @testFields;
}
#adt080401###############################################################################
#
# Subroutine Name
# GetTestsByOwner
#
# Description
# This subroutine searches through the test definition file of the given
# client for all the tests that are owned by the given user id or are public
#
# Inputs
# $clientId -- The id of the client to search through
# $ownedBy -- The name of the owner of the test to search for
#
# Outputs
# None
#
# Returns
# @tests -- An array of tests owned by the given user id
#
################################################################################
sub GetTestsByOwner
{
my $clientId = $_[0];
my $ownedBy = $_[1];
my %currHash;
my @testList = &get_data("tests.$clientId");
my @currField;
my @tests;
my $testHdr = $testList[0];
my $testFields;
my $testCntr;
@testFields = &GetTestHeader( $clientId );
for( $testCntr = 1; $testCntr < $#testList; $testCntr++ )
{
#print "$testList[$testCntr]
\n";
chop( $testList[$testCntr] );
@currField = split( '&', $testList[$testCntr] );
for( 0 .. $#testFields )
{
$currHash{$testFields[$_]} = $currField[$_];
}
#print "$currHash{'ownedby'} - $ownedBy";
if( ( $currHash{'ownedby'} eq $ownedBy ) || ( $currHash{'ownedby'} eq "" ) )
{
push( @tests, $testList[$testCntr] );
#print "$testList[$testCntr]
\n";
}
}
return @tests;
}
#
# Return: Count of test result files in $dir matching regex with $clid
# and $testid, OR -1 if there was an error.
#
sub CountTestFilesByCnd {
my ($dir, $clid, $testid, $cndid) = @_;
if ( ! defined($dir) ) {
&logger::logerr("Undefined directory for client ID '$clid', testid '$testid'");
return -1;
}
if ( ! defined($clid) ) {
&logger::logerr("Undefined client ID for directory '$dir', testid '$testid'");
return -1;
}
if ( ! defined($testid) ) {
&logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'");
return -1;
}
my $tstcount = scalar(get_matching_files($dir, "^$clid".'\.'."$cndid".'\.'."$testid\$"));
return $tstcount;
}
#
# Return: Count of test result files in $dir matching regex with $clid
# and $testid, OR -1 if there was an error.
#
sub CountHistoricTests {
my ($dir, $clid, $testid, $cndid) = @_;
if ( ! defined($dir) ) {
&logger::logerr("Undefined directory for client ID '$clid', testid '$testid'");
return -1;
}
if ( ! defined($clid) ) {
&logger::logerr("Undefined client ID for directory '$dir', testid '$testid'");
return -1;
}
if ( ! defined($testid) ) {
&logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'");
return -1;
}
my $historyfile = join($pathsep,$dir,"$clid.$testid.history");
open (HISTFILE,"<$historyfile") or return 0;
my @histentries = ;
close HISTFILE;
my $sgrepfor=join('&',"\<\<\>\>$clid","$cndid","$testid","");
my @cndidentries = grep( /$sgrepfor/,@histentries);
my $tstcount = $#cndidentries + 1;
return $tstcount;
}
#
# Return: Count of cnd result files in $dir matching regex with $clid
# and $cndid, OR -1 if there was an error.
#
sub CountCndFiles {
my ($dir, $clid, $cndid) = @_;
if ( ! defined($dir) ) {
&logger::logerr("Undefined directory for client ID '$clid', cndid '$cndid'");
return -1;
}
if ( ! defined($clid) ) {
&logger::logerr("Undefined client ID for directory '$dir', cndid '$cndid'");
return -1;
}
if ( ! defined($cndid) ) {
&logger::logerr("Undefined cnd ID for directory '$dir', client ID '$clid'");
return -1;
}
return scalar(get_matching_files($dir, "^$clid".'\.'."$cndid".'\.\S+$'));
}
#
# Return: Sum of times taken during a test in seconds.
#
sub computeTestTime {
my ($dir, $clid, $testid, $cndid, $tstkey) = @_;
if ( ! defined($dir) ) {
&logger::logerr("Undefined directory for client ID '$clid', testid '$testid'");
return -1;
}
if ( ! defined($clid) ) {
&logger::logerr("Undefined client ID for directory '$dir', testid '$testid'");
return -1;
}
if ( ! defined($testid) ) {
&logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'");
return -1;
}
my $timefile = join($pathsep,$dir,"$clid.$cndid.$testid.tim");
open (TLOGFILE,"<$timefile") or return 0;
my @tlogentries = ;
close TLOGFILE;
my $sgrepfor="^$tstkey\&(1)\.(2)\.(.*)\&$clid\&$cndid\&$testid\&(.*)";
my @cndidentries = grep( /$sgrepfor/,@tlogentries);
@tlogentries = ();
my $iidx;
my @tentrycols;
my $tottime;
$tottime = 0;
for $iidx (0 .. $#cndidentries) {
@tentrycols = split(/&/,$cndidentries[$iidx]);
$tottime += $tentrycols[7];
}
@tentrycols = ();
return $tottime;
}
sub formatTimeFromSeconds {
my ($t, $fmt) = @_;
my $h;
my $m;
my $s;
my $r;
my $j;
$m = int($t/60);
$s = $t - ($m * 60);
$h = int($m/60);
$m = $m - ($h * 60);
if ($fmt =~ m/h/i) {
$r = "00000$h";
$j=length($r)-2;
$r = substr($r,$j,2);
$fmt =~ s/h/$r/g;
}
if ($fmt =~ m/m/i) {
$r = "00000$m";
$j=length($r)-2;
$r = substr($r,$j,2);
$fmt =~ s/m/$r/g;
}
if ($fmt =~ m/s/i) {
$r = "00000$s";
$j=length($r)-2;
$r = substr($r,$j,2);
$fmt =~ s/s/$r/g;
}
return $fmt;
}
# Normally xdim was 400 and ydim was 100.
sub BuildBarGraph {
# This subroutine builds the HTML to get an image from an URL.
# The URL is a cgi-bin PERL script, with several parameters.
# The list parameters are: labels, values, and values2.
# The scalar parameters are: xdim, ydim, hbar, title, xlabel, ylabel, ymax, ymin, yticknum, colorscheme, $t_margin, $b_margin, $l_margin, $r_margin
# The first 3 parameters are references to three lists, which are mandatory.
# The values2 list may be an empty list. (and ignored.)
# The rest of the parameters are optional, but are order specific.
# Any parameter that is an empty string will be effectively ignored,
# but may be required to fill the list of parameters to a needed parm.
my @label_names, @value_points, @value2_points ;
my $labels_ref, $values_ref, $values2_ref ;
my $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum ;
my $colorscheme ;
my $t_margin, $b_margin, $l_margin, $r_margin ;
$labels_ref = $_[0] ;
@label_names = @{$labels_ref} ;
# @label_names is an array of character strings of the names of the bars on the graph.
$values_ref = $_[1] ;
@value_points = @{$values_ref} ;
# @value_points is an array of numeric values for each of the names in the first array.
# The sizes of the two arrays should be the same.
$values2_ref = $_[2] ;
@value2_points = @{$values2_ref} ;
shift ; shift ; shift ; # Remove the first 3 parms, to set up the next statement.
($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $colorscheme, $t_margin, $b_margin, $l_margin, $r_margin) = @_ ;
my $labels, $values, $values2 ;
# print '
label_names ' . "@label_names" . '
' ;
# print '
value_points ' . "@value_points" . '
' ;
if ($#label_names != $#value_points) {
print '
ERROR BuildBarGraph has different number of labels and data values.
' ;
}
$labels = join (":", map {munge($_)} @label_names ) ;
$values = join (":", map {munge($_)} @value_points ) ;
$values2 = join (":", map {munge($_)} @value2_points ) ;
# my $baseurl = "/cgi-bin/bargraph.pl?labels=$labels&title=Trust%20Level&ylabel=Respondents";
my $baseurl = "/cgi-bin/bargraph.pl?labels=$labels&values=$values" ;
if ($xdim or $xdim == 0) { $baseurl .= "&xdim=" . $xdim ; }
if ($ydim or $ydim == 0) { $baseurl .= "&ydim=" . $ydim ; }
if ($hbar or $hbar == 0) { $baseurl .= "&hbar=" . $hbar ; }
if ($title or $title == 0) { $baseurl .= "&title=" . munge( $title) ; }
if ($xlabel or $xlabel == 0) { $baseurl .= "&xlabel=" . munge( $xlabel) ; }
if ($ylabel or $ylabel == 0) { $baseurl .= "&ylabel=" . munge( $ylabel) ; }
if ($ymax or $ymax == 0) { $baseurl .= "&ymax=" . $ymax ; }
if ($ymin or $ymin == 0) { $baseurl .= "&ymin=" . $ymin ; }
if ($t_margin or $t_margin == 0) { $baseurl .= "&t_margin=" . $t_margin ; }
if ($b_margin or $b_margin == 0) { $baseurl .= "&b_margin=" . $b_margin ; }
if ($l_margin or $l_margin == 0) { $baseurl .= "&l_margin=" . $l_margin ; }
if ($r_margin or $r_margin == 0) { $baseurl .= "&r_margin=" . $r_margin ; }
if ($colorscheme) { $baseurl .= "&colorscheme=" . $colorscheme ; }
if ($yticknum or $yticknum == 0) { $baseurl .= "&yticknum=" . $yticknum ; }
return "![](\"$baseurl&values2=$values2\")
";
}
############################################################################
#
# Function: munge( $string )
# Description: Do the normal munging to replace non-normal chars with %XX.
# Returns: a modified string with %XX patterns inserted
# Author: HBI, 2008/09/30
#
# The process is performed on strings that are sent as literal text,
# as part of an URL to be re-analyzed by a WEB server. The higher
# level application must do this once, and only once. This function
# assumes that the character string contains only 7 or 8 bit characters.
# This function cannot deal with multi-byte UTF-8 characters.
#
############################################################################
sub munge( $ ) {
my ($string) = @_;
$string =~ s/([^a-zA-Z0-9])/join('', '%', uc(unpack("H*",$1)))/eg;
return $string;
}
############################################################################
#
# Function: unmunge( $string )
# Description: Inverse operation of munge(), replace %XX with the real ascii.
# Returns: a modified string with %XX patterns replaced
# Author: efl, 11/2001
#
############################################################################
sub unmunge( $ ) {
my ($string) = @_;
$string =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
return $string;
}