#!/usr/bin/perl # # Source File: likert_wall_102.pl # # Get config require 'sitecfg.pl'; require 'testlib.pl'; require 'tstatlib.pl'; require 'questionslib.pl'; use bargraph_pnm ; my $last_index, $HBI_Debug ; $HBI_Debug = 0 ; # Controls output of Debugging Data. $FORM{'frm'}=""; my $Eol = "\r\n" ; my $lCurly = "\x7b" ; my $rCurly = "\x7d" ; # $lCurly, and $rCurly are used as curly braces, so vim is not confused # about matching perl code curly braces. use vars qw($Eol $lCurly $rCurly) ; if ($HBI_Debug) {warn __FILE__ . " running" ;} &app_initialize; # frm == 3 code will print all Content info. unless ($FORM{'frm'} == '3') { if ($FORM{'cbexport'} eq 'xport') { print "Content-Disposition: attachment;filename=report.txt\n\n"; $bDisplay = 0; } else { print "Content-Type: text/html\n\n"; $bDisplay = 1; } } # LIKERT Scale Test Reports by Candidate if (&get_session($FORM{'tid'})) { &LanguageSupportInit(); $REPORT{'rptid'}=""; @rptdefs = &get_data("reports.$SESSION{'clid'}"); @lbls = split(/&/, $rptdefs[0]); foreach $rptdef (@rptdefs) { chomp ($rptdef); @flds = split(/&/, $rptdef); if ($flds[0] eq $FORM{'rptno'}) { for $i (0 .. $#lbls) { $REPORT{$lbls[$i]} = $flds[$i]; $i++; } } } if ($FORM{'frm'} == '1') { &show_index_candidates; } elsif ($FORM{'frm'} == '2') { &show_index_tests; } elsif ($FORM{'frm'} == '3') { &show_detail; } elsif ($FORM{'frm'} == '4') { &show_filter_options; } else { print "\n"; print "\n"; print " \n"; print "\n"; } } else { warn __FILE__ . " running without a SESSION." ; } sub show_index_candidates { &log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Report $FORM{'rptno'}"); &get_client_profile($SESSION{'clid'}); print " $REPORT{'rptid'} - $REPORT{'rptdesc'}
$REPORT{'rptid'} - $REPORT{'rptdesc'}
"; my @clrecs = &get_client_cnd_list($CLIENT{'clid'}); my @clnamesort=(); my @clidsort=(); my $namesort; my $idsort; my $mycreator; my $imaregistrar = &get_a_key("cnd.$SESSION{'clid'}", $SESSION{'uid'}, "registrar"); for (1 .. $#clrecs) { $clrecs[$_] =~ s/\n//g; @cndrecs = split(/&/, $clrecs[$_]); $id = $cndrecs[0]; $nmf = $cndrecs[3]; $nmm = $cndrecs[4]; $nml = $cndrecs[5]; $mycreator = $cndrecs[15]; unless (($id eq '') || ($nml eq '')) { $namesort=join('&',$nml,$nmf,$nmm,$id); if ($imaregistrar eq 'Y') { if ($SESSION{'uid'} eq $mycreator) { push @clnamesort, $namesort; } } else { push @clnamesort, $namesort; } } } @clrecs = sort @clnamesort; @clnamesort=(); print "Name:\n"; @clrecs = sort @clidsort; @clidsort=(); print "\ ID:\n"; @clrecs=(); print "
"; } sub show_index_tests { &log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Report $FORM{'rptno'}"); &get_client_profile($SESSION{'clid'}); &get_candidate_profile( $SESSION{'clid'}, $FORM{'cndid'}); my $style = "SELECT {\"width: 200px;height: 200px;font-size: 8pt;\"}"; print " $REPORT{'rptid'} - $REPORT{'rptdesc'}
$CANDIDATE{'nml'}, $CANDIDATE{'nmf'} $CANDIDATE{'nmm'}
"; my @trecs = &get_test_list($CLIENT{'clid'}); my @tmptrecs = (); for (1 .. $#trecs) { ($id, $desc) = split(/&/, $trecs[$_]); $trecs[$_] = join('&', "$desc", "$id"); push @tmptrecs, $trecs[$_]; } @trecs = sort @tmptrecs; print "\t\t
$xlatphrase[721]
"; &log_entry($SESSION{'clid'}, $SESSION{'uid'}, "3", "Exec Report $FORM{'rptno'} completed"); } sub show_filter_options { my $cndid; my $cndname; my @testdates; my $iopt; my $optval; my $optdesc; my $lstdates; my $qcor; my $qinc; my $tscore; my $trash; my $j; my $i; my @tests; my @tmpdates; my $jscript; my $colspan; &log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Report Options $FORM{'rptno'}"); &get_client_profile($SESSION{'clid'}); &get_candidate_profile( $SESSION{'clid'}, $FORM{'cndid'}); @tests = split(/\,/,$FORM{'tstid'}); $cndname = join('', $CANDIDATE{'nml'}, ", ", $CANDIDATE{'nmf'}, " ", $CANDIDATE{'nmm'}); $cndid = $CANDIDATE{'uid'}; $lstdates = "\n"); $styles = "SELECT {\"font-size: 8pt;\"}\n"; $styles = join('',$styles,"INPUT {\"font-size: 8pt;height: 20px;\"}\n"); print " $REPORT{'rptid'} - $REPORT{'rptdesc'}
$testdescriptions
"; if ($TEST{'seq'} eq 'std') { print " "; $colspan="colspan=2"; } else { print " "; $colspan=""; } print "
$xlatphrase[687]
$lstdates
$xlatphrase[687]
$lstdates
"; $testspending = CountTestFilesByCnd($testpending, $CLIENT{'clid'},$id,$FORM{'cndid'}); if ($testspending > 0) { print " Print\ \; Master/Key"; } print "\ 

"; } sub show_detail { my @tentries; my @tcols; my $i; my $j; my $k; my $loidx; my $hiidx; my $loscore; my $hiscore; my $avgscore; my $avgcount; my @testdates; my @found; my $sgrepfor; my $bDisplay; my $timetaken; my $testtitle; my $tstdate; my $testid; my @tmparray; my @tmpdates; my $RTF_PNG_Begin ; my $RTF_PNG_Close ; &log_entry($SESSION{'clid'}, $SESSION{'uid'}, "2", "Exec Report $FORM{'rptno'}"); &get_client_profile($SESSION{'clid'}); # populates the Assoc. array %CLIENT with data for the client id. &get_candidate_profile( $SESSION{'clid'}, $FORM{'cndid'}); # populates the Assoc. array %CANDIDATE with data for the candidate/user/student who took the test/survey. # HBI - Go find the format of the test results. # The original code supported multiple selected tests. # This report does not support multiple tests. &get_test_profile($CLIENT{'clid'}, $FORM{'tstid'}); # populates the Assoc. array %TEST with the characteristics of the test (but not the questions or answers). $foo = get_test_sequence_for_reports($CLIENT{'clid'},$FORM{'cndid'}, $FORM{'tstid'}); # populates the Assoc. arrays %TEST_SESSION, %SUBTEST_QUESTIONS, %SUBTEST_ANSWERS, %SUBTEST_RESPONSES, # and %SUBTEST_SUMMARY. $QUESTIONS_AH = get_question_definitions ($CLIENT{'clid'}, $FORM{'tstid'}); # Populates an array of hashs that contains all of the questions and the answers. # $QUESTIONS_AH is a reference to the arrays of hashs. if ($HBI_Debug) { print "Content-Type: text/html\n\n"; print "\\n" ; print "\\SYSTEM HASH ARRAY\\n" ; foreach $key (sort keys (%SYSTEM)) { print "KEY $key VAL $SYSTEM{$key}\\n" ; } print "\\CLIENT HASH ARRAY\\n" ; foreach $key (sort keys (%CLIENT)) { print "KEY $key VAL $CLIENT{$key}\\n" ; } print "\\SESSION HASH ARRAY\\n" ; foreach $key (sort keys (%SESSION)) { print "KEY $key VAL $SESSION{$key}\\n" ; } print "\\FORM HASH ARRAY\\n" ; foreach $key (sort keys (%FORM)) { print "KEY $key VAL $FORM{$key}\\n" ; } print "\\CANDIDATE HASH ARRAY\\n" ; foreach $key (sort keys (%CANDIDATE)) { print "KEY $key VAL $CANDIDATE{$key}\\n" ; } print "\\TEST HASH ARRAY\\n" ; foreach $key (sort keys (%TEST)) { print "KEY $key VAL $TEST{$key}\\n" ; } print "\\TEST_SESSION HASH ARRAY\\n" ; foreach $key (sort keys (%TEST_SESSION)) { print "KEY $key VAL $TEST_SESSION{$key}\\n" ; } print "\\SUBTEST_QUESTIONS HASH ARRAY\\n" ; foreach $key (sort keys (%SUBTEST_QUESTIONS)) { print "KEY $key VAL $SUBTEST_QUESTIONS{$key}\\n" ; } print "\\SUBTEST_ANSWERS HASH ARRAY\\n" ; foreach $key (sort keys (%SUBTEST_ANSWERS)) { print "KEY $key VAL $SUBTEST_ANSWERS{$key}\\n" ; } print "\\SUBTEST_RESPONSES HASH ARRAY\\n" ; foreach $key (sort keys (%SUBTEST_RESPONSES)) { print "KEY $key VAL $SUBTEST_RESPONSES{$key}\\n" ; } print "\\SUBTEST_SUMMARY HASH ARRAY\\n" ; foreach $key (sort keys (%SUBTEST_SUMMARY)) { print "KEY $key VAL $SUBTEST_SUMMARY{$key}\\n" ; } } # end of if $HBI_Debug $last_index = $#{$QUESTIONS_AH} ; # Last index of the Array of Hashs of the Q&A. my %supercat_total = () ; # Total points available for a category. my %supercat_earned = () ; # Points earned for a category. my %TGWall_Comments = () ; # Collected Text for questions and comments in a category. my %TGWall_Comments_fnd = () ; # Collected Text for questions and comments in a category. # The following values have a similar name, and are logically connected. my $SUPERCAT_TOTAL = 0 ; # Total points available in all categories. my $SUPERCAT_EARNED = 0 ; # Total points earned in all categories. my $points, $weight, @scores, @correct_ans, @incorrect_ans, @all_ans ; my $ques_type, $supercat, $scores, @responses, $responses ; my @individ, $individ, @img_labels, @img_data , @Response_parts; $SYSTEM{'ALL_Comments'} = "" ; $responses = $SUBTEST_RESPONSES{2} ; @responses = split (/\&/, $responses) ; shift @responses ; # Drop the empty element in front of the list. if ($last_index == -1) { print "\\n" if ($HBI_DEBUG) ; print "\\No Questions in the test.\\n" if ($HBI_DEBUG) ; print "\\n" if ($HBI_DEBUG) ; warn "ERROR: No Questions in the test." ; } else { foreach $index1 (0 .. $last_index) { # Get the data for a single question. $points = ${$QUESTIONS_AH}[$index1]->{'pts'} ; $weight = ${$QUESTIONS_AH}[$index1]->{'wght'} ; $ques_type = ${$QUESTIONS_AH}[$index1]->{'qtp'} ; $scores = ${$QUESTIONS_AH}[$index1]->{'scores'} ; @scores = split (/\,/ , $scores) ; $supercat = ${$QUESTIONS_AH}[$index1]->{'supercat'} ; # Populate the responses for all the questions. @Response_parts = split ('::', $responses[$index1], 2) ; ${$QUESTIONS_AH}[$index1]->{'responses'} = $Response_parts[0] ; ${$QUESTIONS_AH}[$index1]->{'comments'} = $Response_parts[1] ; # Parse out any HTML line breaks. # my ($Comment_work_str, $Comment_repl_str) ; # $Comment_work_str = ${$QUESTIONS_AH}[$index1]->{'responses'} ; # while ($Comment_work_str =~ m/( ?)\<[Bb][Rr]\>( ?)/) { # $Comment_repl_str = (((length $1) + (length $2)) == 0) ? " " : "" ; # $Comment_work_str =~ s/\<[Bb][Rr]\>/$Comment_repl_str/ ; # # The while loop forces all of the
to be processed. # # We do not use the global suffix operator for the search # # and replace because the replacement string can be different. # } # ${$QUESTIONS_AH}[$index1]->{'responses'} = $Comment_work_str ; ${$QUESTIONS_AH}[$index1]->{'responses'} =~ s/\s*\\s*/ /isg ; # $Comment_work_str = ${$QUESTIONS_AH}[$index1]->{'comments'} ; # while ($Comment_work_str =~ m/( ?)\<[Bb][Rr]\>( ?)/) { # $Comment_repl_str = (((length $1) + (length $2)) == 0) ? " " : "" ; # $Comment_work_str =~ s/\<[Bb][Rr]\>/$Comment_repl_str/ ; # } # ${$QUESTIONS_AH}[$index1]->{'comments'} = $Comment_work_str ; ${$QUESTIONS_AH}[$index1]->{'comments'} =~ s/\s*\\s*/ /isg ; if ($ques_type eq "lik") { $supercat_total{$supercat} += $points ; $SUPERCAT_TOTAL += $points ; $responses = $responses[$index1] ; @individ = split(/\?/, $responses) ; shift @individ ; foreach $index2 (0 .. $#scores) { print "\index2 $index2 individ elem $individ[$index2] scores elem $scores[$index2]\n" if $HBI_Debug ; if ($individ[$index2] ne "xxx" and $individ[$index2] ne "" and $individ[$index2] == $index2) { $supercat_earned{$supercat} += $scores[$index2] ; $SUPERCAT_EARNED += $scores[$index2] ; print "\supercat $supercat responses $responses index1 $index1 index2 $index2 \\n" if $HBI_Debug ; } } # Collect the questions and comments. unless ($TGWall_Comments{$supercat}) { # First time found the category. $TGWall_Comments{$supercat} = "\\par CATEGORY - " . &RTFize($supercat) . "\n" ; $TGWall_Comments{$supercat} .= "\\par \n" ; } if ($Response_parts[1] =~ m/\S/) { # The question has a comment. $TGWall_Comments{$supercat} .= "\\par Question " . ($index1 + 1) . " - \n" ; $TGWall_Comments{$supercat} .= $lCurly . "\\b0 " . &RTFize(${$QUESTIONS_AH}[$index1]->{'qtx'}) . $rCurly . $Eol ; $TGWall_Comments{$supercat} .= "\\par " . &RTFize(${$QUESTIONS_AH}[$index1]->{'comments'}) . "\n" ; $TGWall_Comments{$supercat} .= "\\par " . "\n" ; $TGWall_Comments_fnd{$supercat} = 1 ; } } # end of if $ques_type } # end foreach $index1 foreach $supercat (sort keys %TGWall_Comments) { unless ($TGWall_Comments_fnd{$supercat}) { $TGWall_Comments{$supercat} .= "\\par NO Comments.\\par\n" ; } $SYSTEM{'ALL_Comments'} .= $TGWall_Comments{$supercat} ; } # print "\\n" ; # print "Candidate: $CANDIDATE{'nmf'} " ; # if ($CANDIDATE{'nmm'}) {print "$CANDIDATE{'nmm'} " ;} # print "$CANDIDATE{'nml'} \\n" ; $SYSTEM{'Graphic_Text'} = "\\par \n" ; $SYSTEM{'Graphic_Text'} .= "Candidate: $CANDIDATE{'nmf'} " ; if ($CANDIDATE{'nmm'}) {$SYSTEM{'Graphic_Text'} .= "$CANDIDATE{'nmm'} " ;} $SYSTEM{'Graphic_Text'} .= "$CANDIDATE{'nml'}\n" ; $CANDIDATE{'full_name'} = $CANDIDATE{'nmf'} . " " ; $CANDIDATE{'full_name'} .= $CANDIDATE{'nmm'} . ". " if ($CANDIDATE{'nmm'}) ; $CANDIDATE{'full_name'} .= $CANDIDATE{'nml'} ; my $percent ; @img_labels = () ; @img_data = () ; my $category_count = keys %supercat_total ; # The number of elements of %supercat_total if ($category_count) { foreach $rep (sort keys %supercat_total) { $percent = int ((100.0 * $supercat_earned{$rep} / $supercat_total{$rep}) +0.5) ; # print "$rep Score: $percent\%\\n" ; $SYSTEM{'Graphic_Text'} .= "\\par $rep Score: $percent\%\n" ; push @img_labels, $rep ; push @img_data, $percent ; } # end of foreach $rep push @img_labels, "Total" ; $percent = int ((100.0 * $SUPERCAT_EARNED / $SUPERCAT_TOTAL) +0.5) ; push @img_data, $percent ; # print "Total Score: $percent\%\\n" ; $SYSTEM{'Graphic_Text'} .= "\\par Total Score: $percent\%\n" ; } else { # $category_count is zero. No categories. # print "\\n" ; # print "\\No Likert Scale Questions in the test.\\n" ; # print "\\n" ; $SYSTEM{'Graphic_Text'} .= "\\par No Likert Scale Questions in the test.\n" ; } $SYSTEM{'Graphic_Text'} .= "\\par \n" ; # The list parameters are: labels, values, and values2. my (@values2, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum) ; # The scalar parameters are: xdim, ydim, hbar, title, xlabel, ylabel, ymax, ymin, yticknum @values2 = () ; ($xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $colorscheme) = (500, 300, 1, "Scores", "Category", "Percent for Category", 100, 0, 10, 1) ; ($t_margin, $b_margin, $l_margin, $r_margin) = (0, 0, 0, 30) ; $ydim = 150 + 30 * $#img_labels ; my $Eol = "\r\n" ; $RTF_PNG_Begin = '{\\*\\shppict' ; $RTF_PNG_Begin .= '{\\pict\\pngblip' ; $RTF_PNG_Begin .= "\\picw${xdim} " ; # Width in pixels $RTF_PNG_Begin .= "\\pich${ydim} " ; # Height in pixels $RTF_PNG_Begin .= "\\picwgoal" . (${xdim}*20) ; # width on the page in twips $RTF_PNG_Begin .= "\\pichgoal" . (${ydim}*20) ; # Height on the page in twips. $RTF_PNG_Begin .= $Eol ; # I am using a pixel in a point. A point is 1/72 inches. # A twip is 1/20 of a point. $RTF_PNG_Begin .= "\\bliptag10000" ; # Unique identifier for the image. $RTF_PNG_Begin .= '{\\*\\blipuid ' ; $RTF_PNG_Begin .= "00000000000000000000000000002710" ; # 32 numeric digits $RTF_PNG_Begin .= '}' . $Eol ; # Ends blipuid. $RTF_PNG_Close = '}}' ; # Ends pict and shppict commands. $RTF_PNG_Close .= $Eol ; my $HBI_Debug_msg_str = "" ; my $T_colors = "" ; # Normally this is a colon separated string of color names. my $png_data = &Build_Graph_PNM(\@img_labels, $T_colors, \@img_data, undef, $xdim, $ydim, $hbar, $title, $xlabel, $ylabel, $ymax, $ymin, $yticknum, $t_margin, $b_margin, $l_margin, $r_margin, $colorscheme) ; my $offset = 0 ; my $length_line = 80 ; my $len_left ; my $part_data = "" ; my $Hex_image = unpack ("H*", $png_data) ; my $All_data_len = length $Hex_image ; do {$len_left = $All_data_len - $offset ; if ($len_left < $length_line) {$length_line = $len_left;} $part_data .= substr($Hex_image, $offset, $length_line) ; $part_data .= $Eol ; $offset += $length_line ; } while ($offset < $All_data_len ) ; $HBI_Debug_msg_str .= " Graph HBI \\par \n" ; $HBI_Debug_msg_str .= "Num. of labels " . $#img_labels . "\\par \n" ; $HBI_Debug_msg_str .= "Num. of points " . $#img_data . "\\par \n" ; $HBI_Debug_msg_str .= "Num. of phg data chars " . (length $png_data) . "\\par \n" ; $HBI_Debug_msg_str .= "Num. of part data chars " . (length $part_data) . "\\par \n" ; # $SYSTEM{'Bargraph1'} = $HBI_Debug_msg_str . $RTF_PNG_Begin . $part_data . $RTF_PNG_Close ; $SYSTEM{'Bargraph1'} = $RTF_PNG_Begin . $part_data . $RTF_PNG_Close ; } # end of if $last_index $testtitle="$FORM{'tstid'} - $TEST{'desc'}"; if ($HBI_Debug) { if ($last_index == -1) { print "\\n" ; print "\\QUESTIONS_AH HASH ARRAY is empty.\\n" ; print "\\n" ; } else { foreach $index (0 .. $last_index) { print "\\n" ; # HBI print "\\QUESTIONS_AH HASH ARRAY Element $index \\n" ; foreach $key (sort keys (%{${$QUESTIONS_AH}[$index]})) { print "KEY $key VAL " ; print "${$QUESTIONS_AH}[$index]->{$key}" ; print "\\n" ; } # end foreach $key } # end foreach $index } # end of if $last_index } # end of if $HBI_Debug # Now we are going to format the date the test was taken. <%=FORM.tdatesel%> # Original text is like 05-Jul-2013_19:37:35_GMT my %Month_Full = ("Jan" => "January", "Feb" => "February", "Mar" => "March", "Apr" => "April", "May" => "May", "Jun" => "June", "Jul" => "July", "Aug" => "August", "Sep" => "September", "Oct" => "October", "Nov" => "November", "Dec" => "December") ; my $given_date_str = $FORM{'tdatesel'} ; my $new_fmt_date ; my ($day_month, $month_str, $cent_year) ; if ($given_date_str =~ m/^(\d+)\-([^\-]+)\-(\d+)/ ) { $day_month = $1 ; $month_str = $2 ; $cent_year = $3 ; $month_str = $Month_Full{$month_str} if ($Month_Full{$month_str}) ; $FORM{'tdatesel'} = "$month_str $day_month, $cent_year" ; } if ($HBI_Debug) { print "\\n" ; print "full name\\n" ; print $CANDIDATE{'full_name'} ; print "\\n" ; print "Test Date\\n" ; print $FORM{'tdatesel'} ; print "\\n" ; print "Graphic Text\\n" ; print $SYSTEM{'Graphic_Text'} ; print "\\n" ; print "Comments\\n" ; print $SYSTEM{'ALL_Comments'} ; print "\\n" ; exit 0 ; } &log_entry($SESSION{'clid'}, $SESSION{'uid'}, "3", "Exec Report $FORM{'rptno'} completed"); $OUTPUT_Format = "RTF" ; print "Content-Type: text/rtf\n"; my $FName = $CANDIDATE{'full_name'} ; $CANDIDATE{'full_name'} = &RTFize($CANDIDATE{'full_name'}) ; foreach $index1 (0 .. $last_index) { ${$QUESTIONS_AH}[$index1]->{'qtx'} = &RTFize(${$QUESTIONS_AH}[$index1]->{'qtx'}) ; ${$QUESTIONS_AH}[$index1]->{'responses'} = &RTFize(${$QUESTIONS_AH}[$index1]->{'responses'}) ; } $FName =~ s/\W/_/g ; print "Content-Disposition: attachment;filename=${FName}_LAP_report.rtf\n\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 ""; } ############################################################################ # # 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; } sub RTFHexEscape { # Return the RTF Hex Escape of the first character in $_. my $oldstr = shift(@_) ; my $retstr = unpack ("H*", substr($oldstr, 0, 1)) ; if ($retstr) { return "\\\'" . $retstr ; } else { return "" ; } } sub RTFize { # Parameter # $textStr - An ASCII text string, not to be modified. # Returned value # $retStr - the $textStr with all special characters converted to special RTF sequences. # Control Characters 0-31, or 0x00 to 0x1F # tab, 0x09, becomes "\tab ". # carriage returns, 0x0D; and line feeds, 0x0A; are left alone. # Other control characters are deleted. # Left Curly Brace becomes \'7b. # Right Curly Brace becomes \'7d. # Back slash becomes \'5c. # Characters 128 to 255 become the hex escaped equivalent. my ($retStr) = @_ ; # Delete special control characters. $retStr =~ s/[\x00-\x08\x0B\x0C\x0E-\x1F]//g ; # Convert the back slash. $retStr =~ s/\\/\\\'5C/g ; # Convert tab. $retStr =~ s/\x09/\\tab /g ; # Convert characters that become the hex escaped value. $retStr =~ s/([\x7b\x7d\x80-\xFF])/&RTFHexEscape($1)/ge ; return $retStr ; }