#!/usr/bin/perl
#
# $Id: testlib.pl,v 1.53 2006/11/10 00:52:01 ddoughty Exp $
# 12/31/01 merged various changes from production site, marked with ##wac
# Source File: testlib.pl
use Data::Dumper;
use MIME::Base64 qw(encode_base64 decode_base64) ;
require 'genutil.pl';
%TEST_STATES = ( _PENDING => 0, _IN_PROGRESS => 1,
_PAUSED_BY_USER => 2, _DECLINED => 3,
_TIME_EXPIRED => 4, _TERMINATED => 5, _COMPLETED => 6 );
%TEST_STATE_DESCRIPTION = ( '0' => 'Pending', '1' => 'In Progress',
'2' => 'Paused by User', '3' => 'Confidentiality Declined',
'4' => 'Time Expired', '5' => 'Terminated by Administrator',
'6' => 'Completed' );
%TEST_SEGMENT_DESCRIPTION = ( '0' => 'Confidentiality', '1' => 'Pretest Survey/Profile',
'2' => 'Core Test', '3' => 'Posttest Profile',
'4' => 'Posttest Survey');
my $HBI_Debug_redirect = 0 ;
# The following variables are used for formatting email messages.
# The email creation and formats of data in the emails
# is not strictly modular. On the down side these values
# are global, created, and used ala side effects. On the
# plus side, flexibility is gained. The variables will all
# be multi-line strings. $MIME_start will be used once and only
# once in each email message, at the very beginning of the email
# message. Its purpose is to tell the email client that the email
# has different sections, with potentially different kinds of data.
# $mm_7bit_text and $mm_encoded_html go at the front of a section
# with its kind of data. $mm_7bit_text is normal 7-bit ASCII
# characters without any special formatting. $mm_encoded_html
# is for base64 uuencoded HTML data.
$MIME_start = "" ;
$mm_7bit_text = "" ;
$mm_encoded_html = "";
sub remove_pending_tests {
my ($clid, $target_cndid) = @_;
opendir(DIR, $testpending);
@dots = readdir(DIR);
closedir DIR;
foreach $rmfile (@dots) {
if ($rmfile =~ /^$clid\.$target_cndid\./ ) {
$ulinkfile = join($pathsep, $testpending, $rmfile);
$cnt = unlink $ulinkfile;
}
}
@dots = ();
}
#hkh 01/04 remove test in progress - indicated by '*' at end of $atest
sub remove_inprogtest {
my ($clid, $target_cndid, $authtests) = @_;
opendir(DIR, $testinprog);
@dots = readdir(DIR);
closedir DIR;
$chgauthtests = "N";
@atests = split(/\;/, $authtests);
foreach $rmfile (@dots) {
$match = "N";
if ($rmfile =~ /^$clid\.$target_cndid\./ ) {
foreach $atest (@atests) {
if ($atest =~ /\*/) {
$_ = $atest;
s/\*//;
if (($rmfile =~ /^$clid\.$target_cndid\.$_/) || ($rmfile =~ /^$clid\.$target_cndid\.$_.tim/)) {
$match = "Y";
}
}
}
if ($match eq "N") {
$ulinkfile = join($pathsep, $testinprog, $rmfile);
$cnt = unlink $ulinkfile;
$chgauthtests = "Y";
}
}
}
@dots = ();
@atests = ();
}
#hkh 01/04 only remove tests in PENDING directory if they were removed in
# candidate registration screen.
sub remove_pending_oldtests {
my ($clid, $target_cndid, $authtests) = @_;
opendir(DIR, $testpending);
@dots = readdir(DIR);
closedir DIR;
my $filename = "tests.$clid";
my @lines = &get_data($filename);
foreach $i (@lines) {
my @banana = split('&', $i);
my $funkey = &get_a_key($filename, $banana[0], "availto");
$funkey =~ s/\./ /;
if ($funkey eq '') { #If funkey eq Y, that means that it IS selfreg. But we want it to find things that are NOT selfreg.
$funkey = "Y ";
} else {
$funkey =~ /^\w\s/;
$funkey = $&;
}
if ($funkey eq "N ") {
my $pendofile = "../secure_html/tests/pending/$clid.$cndid.$banana[0]";
my $pwd = `pwd`;
if ( -e $pendofile) {
if ($authtests ne '') { $authtests .= "\;"; }
$authtests .= "$banana[0]";
}
}
}
@atests = split(/\;/, $authtests);
foreach $rmfile (@dots) {
$match = "N";
if ($rmfile =~ /^$clid\.$target_cndid\./ ) {
foreach $atest (@atests) {
if ($rmfile =~ /^$clid\.$target_cndid\.$atest/) {
$match = "Y";
last;
}
}
if ($match eq "N") {
$ulinkfile = join($pathsep, $testpending, $rmfile);
$cnt = unlink $ulinkfile;
$chgauthtests = "Y";
}
}
}
@dots = ();
@atests = ();
}
#hkh 01/04 add new tests added in candidate registration (--->)
sub create_newtests_list {
my ($clid, $target_cndid, $authtests) = @_;
opendir(DIR, $testpending);
my @dots = readdir(DIR);
closedir DIR;
@newtests = ();
my @atests = split(/\;/, $authtests);
foreach $atest (@atests) {
if ($atest ne '') {
$match = "N";
foreach $rmfile (@dots) {
if ($rmfile =~ /^$clid\.$target_cndid\.$atest/) {
$match = "Y";
} else {
if ($atest=~ /\*/) {
$match = "Y";
}
}
}
if ($match eq "N") {
push(@newtests, $atest);
}
}
}
#hkh 01/04 if nothing is changed on cand. reg. screen, do not pop-up 'Tests
# Registered' message
if (($#newtests == -1) && ($chgauthtests eq "N")) {
$FORM{'respmsg'} = "";
}
@dots = ();
@atests = ();
return @newtests;
}
sub get_pending_tests {
my ($clid, $target_cndid, $opts) = @_;
return &get_tests($clid, $target_cndid, $testpending, $opts);
}
sub get_inprog_tests {
my ($clid, $target_cndid, $opts) = @_;
return &get_tests($clid, $target_cndid, $testinprog, $opts);
}
sub get_completed_tests {
my ($clid, $target_cndid, $opts) = @_;
return &get_tests($clid, $target_cndid, $testcomplete, $opts);
}
sub get_tests {
my ($clid, $target_cndid, $testdir, $opts) = @_;
opendir(DIR, $testdir);
my @files = readdir(DIR);
closedir DIR;
$authtests = "";
foreach $file (@files) {
if ($file =~ /^$clid\.$target_cndid\.(\S+)$/ and $file !~ /\.tim$/) {
my $testid = $1;
$bob=&within_availability_window($clid, $testid, time);
$bobt=time;
if ( ! $opts->{restrict_to_availability_window} ||
&within_availability_window($clid, $testid, time) ) {
$authtests = join(';', $authtests, $testid);
}
}
}
return $authtests;
}
#
# @filelist = &get_test_result_files($directory, $clid, $testid);
#
# Return: List of matching files, or undef if there was an error.
#
sub get_test_result_files {
my ($dir, $clid, $testid) = @_;
if ( ! defined($clid) ) {
&logger::logerr("Undefined client ID for directory '$dir', testid '$testid'");
return undef;
}
if ( ! defined($testid) ) {
&logger::logerr("Undefined test ID for directory '$dir', client ID '$clid'");
return undef;
}
return get_matching_files($dir, "^$clid".'\.\S+\.'."$testid\$");
}
#
# @filelist = &get_cnd_result_files($directory, $clid, $cndid);
#
# Return: List of matching files, or undef if there was an error.
#
sub get_cnd_result_files {
my ($dir, $clid, $cndid) = @_;
if ( ! defined($clid) ) {
&logger::logerr("Undefined client ID for directory '$dir', cndid '$cndid'");
return undef;
}
if ( ! defined($cndid) ) {
&logger::logerr("Undefined cnd ID for directory '$dir', client ID '$clid'");
return undef;
}
return get_matching_files($dir, "^$clid".'\.'."$cndid".'\.\S+$');
}
#
# @filelist = &get_matching_files($directory, $regex);
#
# Return: List of matching files, or undef if there was an error.
#
sub get_matching_files {
my ($dir, $regex) = @_;
if ( ! defined($dir) ) {
&logger::logerr("Undefined directory for client ID '$clid', cndid '$cndid'");
return undef;
}
if ( ! opendir (GDIR, $dir) ) {
&logger::logerr("Unable to open directory '$dir' for reading: $!");
return undef;
}
my @filenames = readdir(GDIR);
closedir GDIR;
my @filelist = ();
foreach $file (sort @filenames) {
if (($file =~ /$regex/i )) {
push @filelist, $file;
}
}
my @converter;
if ($SESSION{'uid'} ne '') {
my $imaregistrar = &get_a_key("cnd.$CLIENT{'clid'}", $SESSION{'uid'}, "registrar");
if ($imaregistrar eq 'Y') {
foreach $rotator (@filelist) {
my @cnd = split(/\./, $rotator);
my $creator = &get_a_key("cnd.$CLIENT{'clid'}", $cnd[1], "createdby");
push(@converter, $rotator) unless $creator ne $SESSION{'uid'};
}
@filelist = @converter;
}
} else {
&logger::logerr("No SESSION{uid} set!");
}
return @filelist;
}
sub get_test_sequence {
$pathpassed = ($#_ == 3) ? 1 : 0;
&get_test_profile($_[0], $_[2]);
if ($pathpassed) {
$trash2 = join($pathsep, "$_[3]", "$_[0].$_[1].$_[2]");
} else {
$trash1 = join($pathsep, $testpending, "$_[0].$_[1].$_[2]");
$trash2 = join($pathsep, $testinprog, "$_[0].$_[1].$_[2]");
$trash3 = join($pathsep, $testcomplete, "$_[0].$_[1].$_[2]");
}
$msg = "";
open(TESTFILE, "<$trash2") or $msg="failed";
if (($msg eq 'failed') && ($pathpassed == 0)) {
$msg = "";
open(TESTFILE,"<$trash1") or $msg="failed";
if ($msg eq 'failed') {
$msg = "";
open(TESTFILE,"<$trash3") or $msg="failed";
}
}
if ($msg eq "failed") {
$msg = "";
} else {
@seqlines = <TESTFILE>;
close TESTFILE;
$isubtest = 1; $iidx = 0; $iaryidx = 1;
foreach $seqline (@seqlines) {
chop ($seqline);
if ($iidx eq 0) {
@status = split(/&/, $seqline);
$ifld = 0;
$TEST_SESSION{'clid'} = $status[$ifld++];
$TEST_SESSION{'uid'} = $status[$ifld++];
$TEST_SESSION{'tstid'} = $status[$ifld++];
$TEST_SESSION{'state'} = $status[$ifld++];
$TEST_SESSION{'dscl'} = $status[$ifld++];
$TEST_SESSION{'profb'} = $status[$ifld++];
$TEST_SESSION{'id'} = $status[$ifld++];
$TEST_SESSION{'profa'} = $status[$ifld++];
$TEST_SESSION{'srvy'} = $status[$ifld++];
$TEST_SESSION{'ntfy'} = $status[$ifld++];
$TEST_SESSION{'emlcnd'} = $status[$ifld++];
@status = ();
$iidx++;
} else {
if ($iaryidx eq 1) {$SUBTEST_QUESTIONS{$isubtest} = $seqline;}
if ($iaryidx eq 2) {$SUBTEST_ANSWERS{$isubtest} = $seqline;}
if ($iaryidx eq 3) {$SUBTEST_RESPONSES{$isubtest} = $seqline;}
if ($iaryidx eq 4) {$SUBTEST_SUMMARY{$isubtest} = $seqline;}
$iaryidx++;
if ($iaryidx eq 5) {
$iaryidx = 1;
$isubtest++;
}
}
}
}
@seqlines = ();
return;
}
sub get_test_sequence_from_history {
my ($dir,$clid,$cndid,$tstid,$testdate) = @_;
my $testseconds = toGMSeconds($testdate);
my @seqlines = ();
&get_test_profile($clid, $tstid);
my $trash = join($pathsep, $dir, "$clid.$tstid.history");
$msg = "";
open(TESTFILE, "<$trash") or $msg="failed to open history file";
if ($msg eq "failed") {
$msg = "";
} else {
@seqlines = <TESTFILE>;
close TESTFILE;
my @histentries;
foreach (@seqlines) {
my ($timestamp,$trash) = split(/\<\<\>\>/, $_);
$timestamp = toGMSeconds($timestamp);
if (abs($testseconds-$timestamp) < 5 && $trash =~ "^$clid\&$cndid\&$tstid\&.*") {
push @histentries, $_;
}
}
if (not @histentries) {
# No entry in History file
return 0;
}
####
#my $sgrepfor = "^$testdate\<\<\>\>$clid\&$cndid\&$tstid\&(.*.)";
#my @histentries = grep(/$sgrepfor/,@seqlines);
#if ($histentries[0] == "") {
# # strip "GMT" and try again
# my $testdate0 = $testdate;
# $testdate0 =~ s/ GMT//g;
# my $sgrepfor = "^$testdate0\<\<\>\>$clid\&$cndid\&$tstid\&(.*.)";
# my @histentries = grep(/$sgrepfor/,@seqlines);
#}
#if ($histentries[0] == "") {
# # convert date to old format and try yet again
# my %months = ("Jan" => 1, "Feb" => 2, "Mar" => 3,
# "Apr" => 4, "May" => 5, "Jun" => 6,
# "Jul" => 7, "Aug" => 8, "Sep" => 9,
# "Oct" => 10, "Nov" => 11, "Dec" => 12);
# my @datearray = split(/ /, $testdate);
# my ($day, $month, $year) = split(/-/, $datearray[0]);
# $datearray[0] = "$year-$months{$month}-$day";
# $testdate = join(" ", @datearray);
# my $sgrepfor = "^$testdate\<\<\>\>$clid\&$cndid\&$tstid\&(.*.)";
# @histentries = grep(/$sgrepfor/,@seqlines);
# @datearray = ();
#}
#if ($histentries[0] == "") {
# # No entry in History file
# return 0;
#}
####
@seqlines = split(/\<\<\>\>/, $histentries[0]);
my @status = split(/&/, $seqlines[1]);
my $ifld = 0;
$TEST_SESSION{'clid'} = $status[$ifld++];
$TEST_SESSION{'uid'} = $status[$ifld++];
$TEST_SESSION{'tstid'} = $status[$ifld++];
$TEST_SESSION{'state'} = $status[$ifld++];
$TEST_SESSION{'dscl'} = $status[$ifld++];
$TEST_SESSION{'profb'} = $status[$ifld++];
$TEST_SESSION{'id'} = $status[$ifld++];
$TEST_SESSION{'profa'} = $status[$ifld++];
$TEST_SESSION{'srvy'} = $status[$ifld++];
$TEST_SESSION{'ntfy'} = $status[$ifld++];
$TEST_SESSION{'emlcnd'} = $status[$ifld++];
@status = ();
$SUBTEST_QUESTIONS{2} = $seqlines[2];
$SUBTEST_ANSWERS{2} = $seqlines[3];
$SUBTEST_RESPONSES{2} = $seqlines[4];
$SUBTEST_SUMMARY{2} = $seqlines[5];
}
@seqlines = ();
return 1;
}
sub promote_test_sequence {
$ffrom = join($pathsep, $_[0], "$TEST_SESSION{'clid'}.$TEST_SESSION{'uid'}.$TEST_SESSION{'tstid'}");
# open(TESTFILE, "<$ffrom") or $msg="failed";
#&dbgprint("promote_test_sequence($_[0]):$_[1]:$_[2]\n");
open(TESTFILE, "<$ffrom") or return;
#&dbgprint("\t$ffrom:-------:$msg\n");
@seqlines = <TESTFILE>;
close TESTFILE;
@tsflds = split(/\./, $TEST_SESSION{'state'});
$TEST_SESSION{'state'} = "$_[2].$tsflds[1].$tsflds[2]";
@tsflds = ();
$hdr = $TEST_SESSION{'clid'};
$hdr = join('&', $hdr, $TEST_SESSION{'uid'});
$hdr = join('&', $hdr, $TEST_SESSION{'tstid'});
$hdr = join('&', $hdr, $TEST_SESSION{'state'});
$hdr = join('&', $hdr, $TEST_SESSION{'dscl'});
$hdr = join('&', $hdr, $TEST_SESSION{'profb'});
$hdr = join('&', $hdr, $TEST_SESSION{'id'});
$hdr = join('&', $hdr, $TEST_SESSION{'profa'});
$hdr = join('&', $hdr, $TEST_SESSION{'srvy'});
$hdr = join('&', $hdr, $TEST_SESSION{'ntfy'});
$hdr = join('&', $hdr, $TEST_SESSION{'emlcnd'});
$fto = join($pathsep, $_[1], "$TEST_SESSION{'clid'}.$TEST_SESSION{'uid'}.$TEST_SESSION{'tstid'}");
open(TESTFILE, ">$fto") or $msg="failed";
print TESTFILE "$hdr\n";
for $iidx (1 .. $#seqlines) {
print TESTFILE "$seqlines[$iidx]";
}
close TESTFILE;
$chmodok = chmod 0666, $fto;
$cnt = unlink $ffrom;
@seqlines=();
#&dbgprint("\t$ffrom:$fto:$msg\n");
}
sub summarize_survey {
}
sub summarize_test {
my $returnval="";
# compute score
# HBI This subroutine is grading the test.
$SUBTEST_RESPONSES{$_[0]} =~ s/\'//g;
#print STDERR "summarize_test($_[0]):$SUBTEST{'id'}:$SUBTEST{'scr'}\n";
#&dbgprint("summarize_test($_[0]):$SUBTEST{'id'}:$SUBTEST{'scr'}\n");
#&dbgprint("\t:$SUBTEST_ANSWERS{$_[0]}\n\t:$SUBTEST_RESPONSES{$_[0]}\n");
# warn "SUBTEST_ANSWERS:$SUBTEST_ANSWERS{$_[0]}\n" ;
# warn "SUBTEST_RESPONS:$SUBTEST_RESPONSES{$_[0]}\n" ;
if ($SUBTEST{'scr'} eq '3') {
$msg = "You have completed this unscored portion of the test.<BR>\n";
$msg = join("", $msg, "Click the Continue button below to proceed.<BR>\n");
$SUBTEST{'score'} = $msg; $msg = "";
$summary = "Not Scored by Definition";
$returnval="u";
} else {
@cans = split(/&/, $SUBTEST_ANSWERS{$_[0]});
# The format of an element of @cans is "answer::subject:weight:points:deduction"
# The default value for weight is one, for points is 100 for the entire test,
# The default for deduction is 0.
@crsp = split(/&/, $SUBTEST_RESPONSES{$_[0]});
# The format of an element of @crsp is "response::comments"
# HBI patterns for scoring -
# ($cans =~ /[0-9]=[0-1]/ ) - Answers are patterns of selected or unselected for multiple selection.
# - separated by question marks, like 0=1?1=1?2=0 the first digit may be in any order.
# ($cans =~ /[anorR]\./ )
# In get_label_index , the letters rR are used for Roman Numerals, Lower and Uppercase, respectively.
# In get_label_index , the letter n is used for Arabic Numerals, 1, 2, 3, etc.
# In get_label_index , the letters aA are used for letters; a,b,c, etc. ; Lower and Uppercase, respectively.
# ($cans =~ m/\,/) (If there is a comma, then there are multiple correct answers, and anyone earns the score.
# $iscorrect = ($cans eq $crsp) ? 1 : 0; # Looks to see if the answer matches the response.
# Builds the variable $byquestion.
$correct = 0;
$incorrect = 0;
$totans = 0;
$byquestion = "";
#&dbgprint("\t:261:$#cans:$#crsp\n");
for (1 .. $#cans) {
$ansmask = "";
($cans, $scoring) = split(/::/, $cans[$_]);
($scsubj, $scwght, $scpts, $scded) = split(/:/, $scoring);
unless ($scwght) { $scwght = 1;}
unless ($scpts) { $scpts = 100 / $#cans;}
unless ($scded) { $scded = 0;}
$cans = lc($cans);
($crsp,$ccmts) = split(/::/, lc($crsp[$_]));
#&dbgprint("\t:271:$_:$cans:$crsp:$ccmts\n");
$crsp =~ s/\'//;
if ($cans =~ /[0-9]=[0-1]/ ) {
@ansopts = split(/\?/, $cans);
shift @ansopts;
for (0 .. $#ansopts) {
$ansdig = ($ansopts[$_] =~ /=1/ ) ? "$_" : "xxx" ;
### DED-07 7/18/2002
#$ansmask = join('', $ansmask, $ansdig);
$ansmask = join('?', $ansmask, $ansdig);
}
#$ansmask =~ s/x//g;
#$crsp =~ s/x//g;
$iscorrect = ($ansmask eq $crsp) ? 1 : 0;
$byquestion = join('/', $byquestion, "$iscorrect.$ansmask.$crsp");
#&dbgprint("\t:284:$_:$#ansopts:$ansmask:$crsp\n");
} elsif ($cans =~ /[anorR]\./ ) {
@ansopts = split(/\./, $cans);
$anstype = shift @ansopts;
if ($anstype eq 'o') {
foreach $ansopt (@ansopts) {
$ansopt++;
### DED 7/17/2002
# $ansmask = join('',$ansmask, $ansopt);
$ansmask = join('?',$ansmask, $ansopt);
}
} else {
@albls=&set_answer_labels($anstype);
for (0 .. $#ansopts) {
$cansord[$ansopts[$_]] = $albls[$_];
}
foreach $cansord (@cansord) {
### DED 7/17/2002
#$ansmask = join('', $ansmask, $cansord);
$ansmask = join('?', $ansmask, $cansord);
}
@cansord = ();
}
#&dbgprint("\t:303:$_:$#ansopts:$anstype:$asnmask:$crsp\n");
$iscorrect = ($ansmask eq $crsp) ? 1 : 0;
$byquestion = join('/', $byquestion, "$iscorrect.$ansmask.$crsp");
} elsif ($cans =~ m/\,/) {
@ansopts = split(/\,/,$cans);
$iscorrect = 0;
foreach $ansopt (@ansopts) {
if ($crsp eq $ansopt) {
$iscorrect = 1;
}
}
#&dbgprint("\t:314:$_:$#ansopts:$crsp\n");
$byquestion = join('/', $byquestion, "$iscorrect.$cans.$crsp");
} else {
$iscorrect = ($cans eq $crsp) ? 1 : 0;
#&dbgprint("\t:318:$_:$cans:$crsp\n");
$byquestion = join('/', $byquestion, "$iscorrect.$cans.$crsp");
}
if ($SUBTEST{'scr'} eq '1') {
# weighted
$correct += ($iscorrect) ? $scwght : 0;
$incorrect += ($iscorrect) ? 0 : $scwght;
$totans += $scwght;
} elsif ($SUBTEST{'scr'} eq '2') {
# cummulative
$correct += ($iscorrect) ? $scpts : 0;
##wac v 01/04/02 this code was not scoring cummulative properly, remove 2 lines, added 1
#remove this: $correct -= ($iscorrect) ? 0 : $scded;
#remove this $incorrect += ($iscorrect) ? 0 : $scpts;
# add next line, don't know why it referred to $scpts.
$incorrect += ($iscorrect) ? 0 : $scded;
##wac ^
$totans += $scpts;
} else {
# percent and default
$totans++;
$correct += ($iscorrect) ? 1 : 0;
$incorrect += ($iscorrect) ? 0 : 1;
}
@ansopts = ();
}
if ($totans == 0) { $totans = 1; }
if ($SUBTEST{'scr'} eq '1') {
# weighted
$score = int(($correct * 100) / $totans);
$scpassing = $SUBTEST{'minpass'};
} elsif ($SUBTEST{'scr'} eq '2') {
# cummulative
$score = ($correct - $incorrect);
$scpassing = ($SUBTEST{'minpass'} / 100) * $totans;
} else {
$score = int(($correct * 100) / $totans);
$scpassing = $SUBTEST{'minpass'};
}
@cans = ();
@crsp = ();
$SUBTEST{'correct'} = $correct;
$SUBTEST{'incorrect'} = $incorrect;
$SUBTEST{'score'} = $score;
if ((defined $scpassing) and ($scpassing ne "") and ($score >= $scpassing)) {
# Passed.
$SUBTEST{'scorebar'} = "greenbar.jpg" ;
$returnval = "p" ;
} else {
# Failed.
$SUBTEST{'scorebar'} = "redbar.jpg" ;
$returnval = "f" ;
}
$SUBTEST{'scorebarwidth'} = ($score * 3);
$summary = join( '&', $SUBTEST{'correct'}, $SUBTEST{'incorrect'});
$summary = join( '&', $summary, $SUBTEST{'score'}, $SUBTEST{'scorebar'});
$summary = join( '&', $summary, $SUBTEST{'scorebarwidth'});
if ($FORM{'submit'} eq 'timeexpired') {
$summary = join( '&', $summary, "TIME EXPIRED");
}
$summary = join( '&', $summary, $byquestion);
}
warn "summarize_test RESULTS correct $correct incorrect $incorrect score $score scpassing $scpassing returnval $returnval \n" ;
warn "summarize_test summary $summary \n" ;
$SUBTEST_SUMMARY{$_[0]} = $summary;
$summary = "";
$score = "";
return $returnval;
}
# ($tsubtest)
# remt
# 0 Never
# 1 On Posting of Answer
# 2 Cumulative At End
# 3 With Question
# rema
# 0 Not Applicable
# 1 Incorrect Answers
# 2 Correct Answers
# 3 Both
sub remediate_summary {
$remediationtext="";
if (($SUBTEST{'remt'} eq '2')
&& ($SUBTEST{'rema'} ne '0')
&& ($SUBTEST{'scr'} ne '3')) {
@tqnos = split(/&/, $SUBTEST_QUESTIONS{$_[0]});
@qrcans = split(/&/, $SUBTEST_ANSWERS{$_[0]});
# jharding, 2004-06-22, corrected the retrieval of $byquestion
# for tests that are timed out. BUG 184.
@summary = split(/&/, $SUBTEST_SUMMARY{$_[0]});
$correct = $summary[0];
$incorrect = $summary[1];
$score = $summary[2];
$scorebar = $summary[3];
$scorebarwidth = $summary[4];
if ($#summary eq '5') {
$byquestion = $summary[5];
} else {
$byquestion = $summary[6];
}
@remediations = split(/\//, $byquestion);
for (1 .. $#remediations) {
($cflag, $cans, $uresp) = split(/\./, $remediations[$_]);
if ( ($SUBTEST{'rema'} eq '3')
|| (($cflag eq '0') && ($SUBTEST{'rema'} eq '1'))
|| (($cflag eq '1') && ($SUBTEST{'rema'} eq '2')) ) {
%SQUESTION = %QUESTION;
&get_question_definition($SUBTEST{'id'}, $SESSION{'clid'}, $tqnos[$_]);
%TMPQUESTION = %QUESTION;
%QUESTION = %SQUESTION;
%SQUESTION=();
if ($SUBTEST{'rema'} eq '1') {
$descriptiontext = "The following lists the questions you answered incorrectly, for your review.";
} elsif ($SUBTEST{'rema'} eq '2') {
$descriptiontext = "The following lists the questions you answered correctly, for your review.";
} else {
$descriptiontext = "The following lists the questions and answers (both correct and incorrect) for your review.";
}
if ($remediationtext eq '') {
$remediationtext="<HR width=100\%>
<FONT COLOR=\"\#FF0000\" SIZE=\"4\">
$descriptiontext<BR>
</FONT>
<HR width=100\%>\n";
}
($qrcans, $trash) = split(/::/, $qrcans[$_]);
$remediation = &question_remediation($_, $cans, $uresp, $qrcans, $cflag);
$remediationtext = join('', $remediationtext, $remediation, "<HR width=100\%>\n");
%TMPQUESTION=();
}
}
if ($remediationtext eq '') {
$remediationtext="<HR width=100\%>
Congratulations on your perfect score.<BR>
<HR width=100\%>\n";
}
@remediations=();
@qrcans=();
}
return $remediationtext;
}
sub question_remediation {
$textofremediation="";
$qtxt = $TMPQUESTION{'qtx'};
$qtxt =~ s/<box>/________/g;
if ($TMPQUESTION{'illustration'} eq '') {
$qillus = "";
} else {
$qillus = "\n$TMPQUESTION{'illustration'}<BR>\n";
}
### DED 3/9/05 Have to split resp from comments
($_[2]) = split(/::/, $_[2]);
if ($_[4]) {
$ctag = "<FONT COLOR=\"green\" SIZE=1>$xlatphrase[137]</FONT>";
} else {
$ctag = "<FONT COLOR=\"red\" SIZE=1>$xlatphrase[692]</FONT>";
}
if ($TMPQUESTION{'qtp'} eq 'mch' ) {
### DED-05 7/17/2002 Replaced:
#$quresp = $_[2];
#$qcresp = $_[1];
### with the following to print long answers during remediation
@labels=&set_answer_labels($TMPQUESTION{'qalb'});
$qanswermatch = "\ <BR>\n";
@txts = split(/\n/, $TMPQUESTION{'qca'});
@txts_wro = split(/\n/, $TMPQUESTION{'qia'});
@tmpquresp = split(/\?/, $_[2]);
shift @tmpquresp;
@ansopts = split(/\?/, $_[1]);
shift @ansopts;
$quresp = "";
$qcresp = "<TABLE>\n<TR>\n<TD>\n";
for (0 .. $#ansopts) {
$ansopt = $ansopts[$_];
$iansopt = &get_label_index($TMPQUESTION{'qalb'},$ansopt);
if ($iansopt == -1) {
$iansopt = 0 ; # HBI Actually an error.
}
$cansord[$iansopt] = $_;
$qcresp = join('',$qcresp,"($ansopt) $txts[$_]<BR>\n");
}
$qcresp = join('',$qcresp, "</TD>\n<TD> </TD>\n<TD>\n");
for (0 .. $#cansord) {
$qcresp = join('',$qcresp, "<I>($labels[$_]) $txts_wro[$cansord[$_]]</I><BR>\n");
}
$qcresp = join('',$qcresp, "</TD>\n</TR>\n</TABLE>\n");
for (0 .. $#tmpquresp) {
### DED-11 7/23/2002 Print " " rather than "xxx"
### for blank response (added following line)
if ( $tmpquresp[$_] eq "xxx" ) { $tmpquresp[$_]=" "; }
$quresp = join('',$quresp,"(",$tmpquresp[$_],") $txts[$_]<BR>\n");
}
@cansord = ();
### END DED-05
} elsif ($TMPQUESTION{'qtp'} eq 'ord' ) {
### DED-04 7/16/2002 Replaced:
#$quresp = $_[2];
#$qcresp = $TMPQUESTION{'qca'};
#$qcresp =~ s/\n/<BR>/g;
### with the following to print long answers during remediation
$quresp = "";
$qcresp = "";
@tmpquresp = split(/\?/, $_[2]);
shift @tmpquresp;
@txts = split(/\n/, $TMPQUESTION{'qca'});
@ansopts = split(/\?/, $_[1]);
shift @ansopts;
for (0 .. $#ansopts) {
$ansopt = $ansopts[$_];
### DED 8/10/2002 Removed labels as "o" is used now
$iansopt = $ansopt;
$iansopt--;
$qcresp = join('',$qcresp,"($ansopt) $txts[$iansopt]<BR>\n");
### DED-12 7/23/2002 Print " " rather than "xxx"
### for blank response (added following line)
if ( $tmpquresp[$_] eq "xxx" ) { $tmpquresp[$_]=" "; }
$quresp = join('',$quresp,"(",$tmpquresp[$_],") $txts[$iansopt]<BR>\n");
}
### END DED-04
### DED-13 7/30/2002 Removed following and merged mcs logic
### with mcm logic for "?" delimiter
#} else {
#if ($TMPQUESTION{'qtp'} eq 'mcs' ) {
#@qrans=split(/\n/, $TMPQUESTION{'qia'});
#unshift @qrans, $TMPQUESTION{'qca'};
#@qrcansidx = split(/\?/, $_[3]);
#shift @qrcansidx;
#($qurespidx, $trash) = split(/=/, $qrcansidx[$_[2]]);
#$quresp = $qrans[$qurespidx];
#$qcresp = $TMPQUESTION{'qca'};
#$qdx="\n<!--\n$_[2],$qrcansidx[$_[2]],$qurespidx,$qrans[$qurespidx],$quresp\n-->\n";
#@qrcansidx = ();
#@qrans=();
#} elsif ($TMPQUESTION{'qtp'} eq 'mcm' ) {
} elsif (($TMPQUESTION{'qtp'} eq 'mcm' ) || ($TMPQUESTION{'qtp'} eq 'mcs' ) || ($TMPQUESTION{'qtp'} eq 'lik' )) {
### DED-06 7/17/2002 Replaced:
#$quresp = $_[2];
#$qcresp = $TMPQUESTION{'qca'};
#$qcresp =~ s/\n/<BR>/g;
### with the following to print long answers during remediation
$qcresp = "";
$quresp = "";
@tmpquresp = split(/\?/, $_[2]);
shift @tmpquresp;
$keyresponse = $_[3];
@txts = split(/\n/, $TMPQUESTION{'qca'});
@txts_wro = split(/\n/, $TMPQUESTION{'qia'});
foreach $qia (@txts_wro) {
push @txts, $qia;
}
@kans = split(/\?/,$keyresponse);
foreach $j (1 .. $#kans) {
$jidx = $j-1;
@indexs = split(/=/, $kans[$j]);
$checked = ($indexs[1] == '1') ? " CHECKED" : "";
$qcresp = join('',$qcresp,"<input type=\"checkbox\"$checked>$txts[$indexs[0]]<BR>\n");
$checked = ($tmpquresp[$jidx] eq $jidx) ? " CHECKED" : "";
$quresp = join('',$quresp,"<input type=\"checkbox\"$checked>$txts[$indexs[0]]<BR>\n");
}
### END DED-06
### DED-14 8/9/2002 Added "esa" section below to show multiple answers
} elsif ($TMPQUESTION{'qtp'} eq 'esa' ) {
$quresp = $_[2];
$qcresp = $TMPQUESTION{'qca'};
$qcresp =~ s/\n/\<br\>/g;
### END DED-14
} else {
$quresp = $_[2];
$qcresp = $TMPQUESTION{'qca'};
}
$textofremediation = "<TABLE border=0>
<TR>
<TD colspan=1 align=\"left\" valign=top rowspan=3>
$ctag
</TD>
<TD colspan=2 align=\"left\">
$qillus
<B><%=PHRASE.328%> $_[0].\ \;\ \;</B>
$qtxt<BR>
</TD>
</TR>
<TR>
<TD align=\"left\">
<B>YOUR ANSWER(S):</B><BR>
$quresp<BR>$qdx
</TD>
<TD align=\"left\">
<B>CORRECT ANSWER(S):</B><BR>
$qcresp<BR>
</TD>
</TR>
<TR>
<TD colspan=2 align=\"left\">
";
if ($TMPQUESTION{'qrm'} ne "") {
$textofremediation .= " <FONT SIZE=\"2\" COLOR=\"#FF0000\">
<B>EXPLANATION:</B><BR>
$TMPQUESTION{'qrm'}
</FONT>
";
}
$textofremediation .= "
</TD>
</TR>
</TABLE>
";
return $textofremediation;
}
################################################################
# REMEDIATION FIX
# if remediated on posting prepare the text of the remediation
################################################################
sub score_question {
my ($tsubtest,$tqno,$qcans,$qresp) = @_;
#&dbgprint("REMEDIATION FIX:testlib:602 score_question: tsubtest:$tsubtest tqno:$tqno qcans:$qcans qresp:$qresp\n");
my $ansmask = "";
my $iscorrect=0;
my ($cans,$trash) = split(/::/, lc($qcans));
my ($crsp,$trash2) = split(/::/, lc($qresp));
$crsp =~ s/\'//;
#&dbgprint("REMEDIATION FIX:testlib:614 score_question: cans:$cans crsp:$crsp\n");
if ($cans =~ /[0-9]=[0-1]/ ) {
my @ansopts = split(/\?/, $cans);
shift @ansopts;
for (0 .. $#ansopts) {
my $ansdig = ($ansopts[$_] =~ /=1/ ) ? "$_" : "xxx" ;
$ansmask = join('?', $ansmask, $ansdig);
}
#&dbgprint("REMEDIATION FIX:testlib:622 score_question: ansmask:$ansmask crsp:$crsp\n");
$iscorrect = ($ansmask eq $crsp) ? 1 : 0;
@ansopts = ();
} elsif ($cans =~ /[anorR]\./ ) {
my @ansopts = split(/\./, $cans);
my $anstype = shift @ansopts;
if ($anstype eq 'o') {
foreach my $ansopt (@ansopts) {
$ansopt++;
$ansmask = join('?',$ansmask, $ansopt);
}
} else {
my @albls=&set_answer_labels($anstype);
my @cansord=();
for (0 .. $#ansopts) {
$cansord[$ansopts[$_]] = $albls[$_];
}
foreach my $cansord (@cansord) {
$ansmask = join('?', $ansmask, $cansord);
}
@cansord = ();
@albls=();
}
#&dbgprint("REMEDIATION FIX:testlib:645 score_question: ansmask:$ansmask crsp:$crsp\n");
$iscorrect = ($ansmask eq $crsp) ? 1 : 0;
@ansopts = ();
} elsif ($cans =~ m/\;/) {
my @ansopts = split(/\;/,$cans);
$iscorrect = 0;
foreach my $ansopt (@ansopts) {
if ($crsp eq $ansopt) {
$iscorrect = 1;
}
}
#&dbgprint("REMEDIATION FIX:testlib:656 score_question: ansmask:$ansmask crsp:$crsp\n");
@ansopts = ();
} else {
#&dbgprint("REMEDIATION FIX:testlib:659 score_question: cans:$cans crsp:$crsp\n");
$iscorrect = ($cans eq $crsp) ? 1 : 0;
}
return $iscorrect;
}
################################################################
# REMEDIATION FIX
# if remediated on posting prepare the text of the remediation
################################################################
# ($tsubtest, $tqno)
#sub remediate_question {
# return "";
#}
sub remediate_question {
my ($tsubtest,$tqno) = @_;
#&dbgprint("REMEDIATION FIX:testlib:675 remediate_question: $tsubtest, $tqno\n");
#&dbgprint("REMEDIATION FIX:testlib:676 remediate_question: REMT:$TEST{'remt'} REMA:$TEST{'rema'}\n");
if (($TEST{'remt'} ne '1')
|| ($TEST{'rema'} eq '0')) {
return "";
}
my $remediation="";
my @tqnos = split(/&/, $SUBTEST_QUESTIONS{$tsubtest});
my @qrcans = split(/&/, $SUBTEST_ANSWERS{$tsubtest});
my @qresp = split(/&/, $SUBTEST_RESPONSES{$tsubtest});
my $cans = $qrcans[$tqno]; # = $_[1] ###############
my $uresp = $qresp[$tqno]; # = $_[2] ###############
my $cflag = &score_question($tsubtest,$tqno,$cans,$uresp);
#&dbgprint("REMEDIATION FIX:testlib:691 remediate_question: cflag:$cflag cans:$cans uresp:$uresp\n");
#
# IF rema (='3') is remediate on both correct & incorrect answers)
# OR uresp is incorrect (='0') and rema (='1') is remediate only on incorrect
# OR uresp is correct (='1') and rema (='2') is remediate only on correct
#
if ( ($TEST{'rema'} eq '3')
|| (($cflag eq '0') && ($TEST{'rema'} eq '1'))
|| (($cflag eq '1') && ($TEST{'rema'} eq '2')) ) {
%SQUESTION = %QUESTION;
&get_question_definition($SUBTEST{'id'}, $SESSION{'clid'}, $tqnos[$tqno]);
%TMPQUESTION = %QUESTION;
%QUESTION = %SQUESTION;
%SQUESTION=();
my ($qrcans, $trash) = split(/::/, $cans);
$remediation = ($cflag == 1) ? "<H1><font color=darkgreen><%=PHRASE.137%></font></H1>" : "<H1><font color=red><%=PHRASE.343%></font></H1>";
my $qremediation = &question_remediation($tqno, $cans, $uresp, $qrcans);
$remediation .= $qremediation;
my $remfixdbglen=length($remediation);
#&dbgprint("REMEDIATION FIX:testlib:708 question_remediation: FREM:$remfixdbglen\n");
%TMPQUESTION=();
$remediation .= "<TABLE border=0 width=\"100\%\">
<TR>
<TD align=\"center\">
<FONT SIZE=\"2\" COLOR=\"#FF0000\">
<input type=submit name=submit value=\"<%=PHRASE.566%>\">
</FONT>
</TD>
</TR>
</TABLE>
";
} else {
$FORM{'remediated'} = "Y";
}
return $remediation;
}
sub create_test_sequence {
$trash = join($pathsep, $testpending, "$_[0].$_[1].$_[2]");
open(TESTFILE, ">$trash") or $msg="failed";
@rows=&package_test_sequence();
foreach $row (@rows) {
print TESTFILE "$row\n";
}
close TESTFILE;
$chmodok = chmod 0666, $trash;
############################################
# addition Backup of registered test
#vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
# my $coreid = sprintf( "\%d", time);
# $trash = join($pathsep, $testpending, "$_[0].$_[1].$_[2].$coreid");
# open(TESTFILE, ">$trash") or $msg="failed";
# foreach $row (@rows) {
# print TESTFILE "$row\n";
# }
# close TESTFILE;
# $chmodok = chmod 0666, $trash;
#^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
# addition Backup of registered test
############################################
}
sub put_test_sequence {
$trash = join($pathsep, $_[0], "$_[1].$_[2].$_[3]");
open(TESTFILE, ">$trash") or $msg="failed";
@pkg=&package_test_sequence();
foreach $row (@pkg) {
print TESTFILE "$row\n";
}
close TESTFILE;
@pkg=();
}
sub package_test_sequence {
@rows=();
$hdr = $TEST_SESSION{'clid'};
$hdr = join('&', $hdr, $TEST_SESSION{'uid'});
$hdr = join('&', $hdr, $TEST_SESSION{'tstid'});
$hdr = join('&', $hdr, $TEST_SESSION{'state'});
$hdr = join('&', $hdr, $TEST_SESSION{'dscl'});
$hdr = join('&', $hdr, $TEST_SESSION{'profb'});
$hdr = join('&', $hdr, $TEST_SESSION{'id'});
$hdr = join('&', $hdr, $TEST_SESSION{'profa'});
$hdr = join('&', $hdr, $TEST_SESSION{'srvy'});
$hdr = join('&', $hdr, $TEST_SESSION{'ntfy'});
$hdr = join('&', $hdr, $TEST_SESSION{'emlcnd'});
push @rows, $hdr;
$ipts = 1;
for $ipts (1 .. 4) {
push @rows, $SUBTEST_QUESTIONS{$ipts};
push @rows, $SUBTEST_ANSWERS{$ipts};
push @rows, $SUBTEST_RESPONSES{$ipts};
push @rows, $SUBTEST_SUMMARY{$ipts};
}
return @rows;
}
sub put_question_response {
my $questionNo = $_[1];
$qrs = ($FORM{'marked'} ne '') ? "\'" : "";
### DED 8/9/2002 Separated mcs logic from mcm
### DED 9/2002 Added mca for adaptive
if (($QUESTION{'qtp'} eq 'mcs') || ($QUESTION{'qtp'} eq 'mca') || ($QUESTION{'qtp'} eq 'lik')) {
@ansc = split(/\n/, $QUESTION{'qca'});
@answ = split(/\n/, $QUESTION{'qia'});
$nanso = $#ansc + $#answ + 1;
for $ipqr (0 .. $nanso) {
### DED 8/20/2002
#if (($ipqr != "") && ($ipqr == $FORM{'qrs'})) {
if ( (($FORM{'qrs'} != "") || ($FORM{'qrs'} =~ /0/)) && ($ipqr == $FORM{'qrs'}) ) {
$qrs = join('?', $qrs, $ipqr);
} else {
$qrs = join('?', $qrs, "xxx");
}
}
### DED 6/28/04 Don't add unanswered to review list
#$rdig = $qrs;
#$rdig =~ s/xxx//g;
#$rdig =~ s/\?//g;
#if ($rdig eq '') { $qrs = join('', "\'", $qrs);}
} elsif ($QUESTION{'qtp'} eq 'mcm') {
@ansc = split(/\n/, $QUESTION{'qca'});
@answ = split(/\n/, $QUESTION{'qia'});
$nanso = $#ansc + $#answ + 1;
for $ipqr (0 .. $nanso) {
if( $TEST{'seq'} eq 'svy' || ($TEST{'seq'} eq 'dmg' && $TEST{'group'} eq 'Y'))
{
$rkey = "q$questionNo";
$rkey = join( '-', $rkey, "qrs$ipqr" );
}
else
{
$rkey = "qrs$ipqr";
}
$rdig = ($FORM{$rkey} eq '') ? "xxx" : $FORM{$rkey};
### DED 7/18/2002
#$qrs = join('', $qrs, $rdig);
$qrs = join('?', $qrs, $rdig);
}
### DED 6/28/04 Don't add unanswered to review list
#$rdig = $qrs;
#$rdig =~ s/xxx//g;
#$rdig =~ s/\?//g;
#if ($rdig eq '') { $qrs = join('', "\'", $qrs);}
} elsif ($QUESTION{'qtp'} eq 'mtx' || $QUESTION{'qtp'} eq 'mtr') {
($rows, $numrows, $numcols, $cols) = split(/::/, $QUESTION{'qia'});
@rows = split(/\n/, $rows);
@cols = split(/\n/, $cols);
for $row (0 .. $#rows) {
for (0 .. $#cols) {
if( $TEST{'seq'} eq 'svy' || ($TEST{'seq'} eq 'dmg' && $TEST{'group'} eq 'Y'))
{
$rkey = "q$questionNo";
$rkey = join( '-', $rkey, "qrs$row$_" );
}
else
{
$rkey = "qrs$row$_";
}
if ($FORM{$rkey} ne '') {
$qrs = join('?', $qrs, $FORM{$rkey});
} else {
$qrs = join('?', $qrs, "xxx");
}
}
}
### DED 6/28/04 Don't add unanswered to review list
#$resp = $qrs;
#$resp =~ s/xxx//g;
#$resp =~ s/\?//g;
#if ($resp eq '') { $qrs = join('', "\'", $qrs);}
#$resp = '';
} elsif (($QUESTION{'qtp'} eq 'mch') || ($QUESTION{'qtp'} eq 'ord')) {
@ansc = split(/\n/, $QUESTION{'qca'});
$nanso = $#ansc;
for $ipqr (0 .. $nanso) {
if( $TEST{'seq'} eq 'svy' )
{
$rkey = "q$questionNo";
$rkey = join( '-', $rkey, "qrs$ipqr" );
}
else
{
$rkey = "qrs$ipqr";
}
$rdig = ($FORM{$rkey} eq '') ? "xxx" : $FORM{$rkey};
$rdig =~ s/\+/ /g;
$rdig =~ s/\&/and/g;
### DED-08 7/17/2002 Replaced
#$qrs = join('', $qrs, $rdig);
# with
$qrs = join('?', $qrs, $rdig);
### END DED-08
}
### DED 6/28/04 Don't add unanswered to review list
#if ($rdig =~ /xxx/ ) { $qrs = join('', "\'", $qrs);}
} elsif ($QUESTION{'qtp'} eq 'esa' || $QUESTION{'qtp'} eq 'nrt') {
### DED 6/28/04 Don't add unanswered to review list
#if ($FORM{'qrs'} eq '') {
#$qrs = "\'";
#} else {
$qrsu = $FORM{'qrs'};
### DED-15 8/9/2002 Added line below to strip "+"s
$qrsu =~ s/\+/ /g;
$qcmt =~ s/\r\n/<BR>/g;
$qcmt =~ s/\r/<BR>/g;
$qrsu =~ s/\n/<BR>/g;
$qrsu =~ s/\&/and/g;
#$qrsu = munge($qrsu);
$qrs = join('', $qrs, $qrsu);
#}
} else {
$qrs = join('', $qrs, $FORM{'qrs'});
### DED 6/28/04 Don't add unanswered to review list
#if ($qrs eq '') { $qrs = "\'";}
}
@resps = split(/&/, $SUBTEST_ANSWERS{$_[0]});
$nresps = $#resps;
##############################################
# added logging of question response
#vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "9", "Q\:$questionNo\:$QUESTION{'qid'}\:\:\:\:A\:$resps[$questionNo]\:\:\:\:R\:$qrs");
#^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
##############################################
@resps = split(/&/, $SUBTEST_RESPONSES{$_[0]});
$rspflds = "";
my $qcmt;
for $ipqr (1 .. $nresps) {
if ($_[1] eq $ipqr) {
$qcmt = $FORM{'qcucmt'};
$qcmt =~ s/\+/ /g ;
$qcmt =~ s/\r\n/<BR>/g;
$qcmt =~ s/\r/<BR>/g;
$qcmt =~ s/\n/<BR>/g;
$qcmt =~ s/\&/and/g;
$rspflds = join('&', $rspflds, "$qrs\:\:$qcmt");
##############################################
# added logging of question response
#vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
if ($qcmt ne '') {
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "9", "Q\:$questionNo\:$QUESTION{'qid'}\:\:\:\:C\:$qcmt");
}
#^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
##############################################
} else {
$rspflds = join('&', $rspflds, $resps[$ipqr]);
}
}
$SUBTEST_RESPONSES{$_[0]} = $rspflds;
$rspflds = "";
@resps = ();
@ansc = ();
@answ = ();
@anso = ();
}
sub get_previous_response {
@resps = split(/&/, $SUBTEST_RESPONSES{$_[0]});
$resp = $resps[$_[1]];
#efl v 12/??/01
#old $resp =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/g;
# replace with unmunge
$resp = unmunge($resp);
#efl ^
### DED 7/8/04 Moved out to tqrs.pl so marked questions stay marked
#$resp =~ s/\'//;
@resps = ();
return $resp;
}
sub find_next_marked {
@resps = split(/&/, $SUBTEST_RESPONSES{$_[0]});
$nmresps = $#resps;
$nsresps = $_[1];
$nsresps = ($_[1] eq $nmresps) ? 1 : $nsresps + 1;
if ($nsresps > $nmresps) { $nsresps = 1;}
for ($nsresps .. $#resps) {
$resp = $resps[$_];
if ($resp =~ /\'/) {
return $_;
}
}
$nsresps--;
if ($nresps > 0) {
for (1 .. $nsresps) {
$resp = $resps[$_];
if ($resp =~ /\'/) {
return $_;
}
}
}
return 0;
}
sub find_next_unanswered {
@resps = split(/&/, $SUBTEST_RESPONSES{$_[0]});
$nmresps = $#resps;
$nsresps = $_[1];
$nsresps = ($_[1] eq $nmresps) ? 1 : $nsresps + 1;
if ($nsresps > $nmresps) { $nsresps = 1;}
for ($nsresps .. $#resps) {
($resp, $trash) = split(/:/, $resps[$_]);
$resp =~ s/\'//g;
$resp =~ s/\?xxx//g;
if ($resp eq '') {
return $_;
}
}
$nsresps--;
if ($nresps > 0) {
for (1 .. $nsresps) {
($resp, $trash) = split(/:/, $resps[$_]);
$resp =~ s/\'//g;
$resp =~ s/\?xxx//g;
if ($resp eq '') {
return $_;
}
}
}
return 0;
}
sub find_marked_unanswered {
my $marked = ":";
my $unanswered = ":";
my @resps = split(/&/, $SUBTEST_RESPONSES{$_[0]});
for (1 .. $#resps) {
($resp, $trash) = split(/:/, $resps[$_]);
$resp =~ s/\?xxx//g;
if ($resp =~ /\'/) {
$marked .= "$_:";
}
$resp =~ s/\'//g;
if ($resp eq '') {
$unanswered .= "$_:";
}
}
if ($marked eq ":") { $marked = "" }
if ($unanswered eq ":") { $unanswered = "" }
return ($marked, $unanswered);
}
sub build_question_dropdown_list {
my ($tsubtest, $marked, $unanswered) = @_;
my $questionlist = "";
my @questions=&get_question_list($TEST{'id'}, $SESSION{'clid'});
my %qlist = {};
for (1 .. $#questions) {
my $qflds = $questions[$_];
chop ($qflds);
my @qdata = split(/&/, $qflds);
my ($trash, $qsno) = split(/\./, $qdata[0]);
$qlist{$qsno} = substr($qdata[4],0,20);
}
@qdata = ();
my @tquestions = split(/\&/, $SUBTEST_QUESTIONS{$tsubtest});
for (1 .. $#tquestions) {
$qind1 = ($marked =~ /:$_:/) ? 'R' : "\ \ ";
$qind2 = ($unanswered =~ /:$_:/) ? 'U' : "\ \ ";
my ($trash, $qsno) = split(/\./, $tquestions[$_]);
$listtext = sprintf("(%u) %20s", $_, $qlist{$qsno});
if ($TEST{'qpv'} eq 'Y' || $qind1 eq 'R' || $qind2 eq 'U') {
$questionlist = join('', $questionlist, "<OPTION VALUE=\"$_\">$qind1$qind2 $listtext</OPTION>\n");
}
}
@questions = ();
@tquestions = ();
@qlist = ();
return $questionlist;
}
sub get_question_id {
@qids = split(/&/, $SUBTEST_QUESTIONS{$_[0]});
$qid = $qids[$_[1]];
@qids = ();
return $qid;
}
sub prepare_test {
my ($clid, $cndid, $authtests, $usetestform, $rmtests) = @_;
my $retakeoptions="";
&get_client_profile($clid);
my $opts = { restrict_to_availability_window => 0 };
if ($SESSION{'taclid'} eq '') {
&get_candidate_profile( $clid, $cndid, $opts);
} else {
&get_tacl_profile();
}
&remove_inprogtest($clid, $cndid, $authtests);
#&remove_pending_oldtests($clid, $cndid, $authtests);
if ($rmtests ne '') {
my @rmtests = split(/\;/, $rmtests);
shift @rmtests;
foreach (@rmtests) {
my $pendfile = join($pathsep, $testpending, "$clid.$cndid.$_");
if (-e $pendfile) {
unlink $pendfile;
}
}
}
my @atests = &create_newtests_list($clid, $cndid, $authtests);
my @testforms = split(/:/, $usetestform);
$SYSTEM{'testprepmsg'}="";
$SYSTEM{'testpreperror'}="";
foreach $atest (@atests) {
if ($atest ne '') {
&get_test_profile($clid, $atest);
$TEST_SESSION{'clid'} = $clid;
$TEST_SESSION{'uid'} = $cndid;
$TEST_SESSION{'tstid'} = $atest;
$TEST_SESSION{'state'} = "0.0.0";
$TEST_SESSION{'dscl'} = $TEST{'dscl'};
$TEST_SESSION{'profb'} = $TEST{'profb'};
$TEST_SESSION{'id'} = $TEST{'id'};
$TEST_SESSION{'profa'} = $TEST{'profa'};
$TEST_SESSION{'srvy'} = $TEST{'srvy'};
$TEST_SESSION{'ntfy'} = $TEST{'ntfy'};
$TEST_SESSION{'emlcnd'} = $TEST{'emlcnd'};
@tseqs = ( $TEST{'dscl'}, $TEST{'profb'}, $TEST{'id'}, $TEST{'profa'}, $TEST{'srvy'} );
for $isubtest (1 .. 4) {
$SUBTEST_QUESTIONS{$isubtest} = "";
$SUBTEST_ANSWERS{$isubtest} = "";
$SUBTEST_RESPONSES{$isubtest} = "";
$SUBTEST_SUMMARY{$isubtest} = "";
if ($tseqs[$isubtest] ne '') {
# DBG &dbgprint("\t$isubtest:$tseqs[$isubtest]\n");
&get_subtest_profile($clid, $tseqs[$isubtest]);
# sac - start addition for subject area percentage support
# (replaced) $SUBTEST_QUESTIONS{$isubtest} = &build_questions( $clid, $tseqs[$isubtest], $SUBTEST{'noq'});
# (with)
&IsTestSBA($clid,$tseqs[$isubtest]);
$SYSTEM{'testpreperror'}="";
# DED 6/9/04 handle uploaded test forms
if ($isubtest == 2) {
$testform = "";
foreach $atestform (@testforms) {
if ($atestform eq $tseqs[$isubtest]) {
$testform = $atestform;
break;
}
}
$SUBTEST_QUESTIONS{$isubtest} = &build_questions( $clid, $tseqs[$isubtest], $SUBTEST{'noq'}, $testform);
} else {
$SUBTEST_QUESTIONS{$isubtest} = &build_questions( $clid, $tseqs[$isubtest], $SUBTEST{'noq'});
}
last if ($SYSTEM{'testpreperror'} ne "");
# sac - end addition for subject area percentage support
$SUBTEST_ANSWERS{$isubtest} = &build_answers( $tseqs[$isubtest], $clid, $isubtest, $SUBTEST{'noq'});
@rspflds = split(/&/, $SUBTEST_ANSWERS{$isubtest});
$rspspc = "";
foreach $rspfld (@rspflds) {
$rspspc = join('&', $rspspc, "");
}
$SUBTEST_RESPONSES{$isubtest} = $rspspc;
$rspspc = "";
@rspflds = ();
# v sac support for retake options
$retakeoptions=$SUBTEST{'slfregenab'};
$retakeoptions=join('.',$retakeoptions,$SUBTEST{'retkcnt'});
$retakeoptions=join('.',$retakeoptions,$SUBTEST{'retkcndtn'});
$retakeoptions=join('.',$retakeoptions,$SUBTEST{'retkwt'});
$retakeoptions=join('.',$retakeoptions,$SUBTEST{'retkwtdly'});
$retakeoptions=join('.',$retakeoptions,$SUBTEST{'retkkeep'});
$retakeoptions=join('.',$retakeoptions,$SUBTEST{'retkautorgstrenab'});
$SUBTEST_QUESTIONS{$isubtest} = join('',$retakeoptions,$SUBTEST_QUESTIONS{$isubtest});
# ^ sac support for retake options
}
}
# sac - start addition for subject area percentage support
# (replaced)
# &create_test_sequence($clid, $cndid ,$atest);
# (with)
if ($SYSTEM{'testpreperror'} eq "") {
&create_test_sequence($clid, $cndid ,$atest);
} else {
$SYSTEM{'testprepmsg'}=join('',$SYSTEM{'testprepmsg'},$SYSTEM{'testpreperror'});
$SYSTEM{'testpreperror'}="";
}
# sac - end addition for subject area percentage support
}
}
@atests = ();
@tseqs = ();
}
sub build_questions {
if ($_[3] ne '') {
# DED 6/9/04 use test form
$qseq = &build_formqseq($_[1], $_[0]);
} elsif (($SUBTEST{'seq'} eq 'std') || ($SUBTEST{'seq'} eq 'svy')) {
# sac - start addition for subject area percentage support
if ($SUBTEST{'IsTestSBA'}) {
$qseq = &build_rndqseq_sba($_[1], $_[0], $_[2]);
} else {
# sac - end addition for subject area percentage support
if ($SUBTEST{'rndq'} eq 'Y') {
$qseq = &build_rndqseq($_[1], $_[0], $_[2]);
} else {
$qseq = &build_stdqseq($_[1], $_[0], $_[2]);
}
# sac - start addition for subject area percentage support
}
# sac - end addition for subject area percentage support
} elsif ($SUBTEST{'seq'} eq 'dmg') {
### DED 9/11/02 Adaptive Survey (dmg) support
$qseq = &build_stdqseq($_[1], $_[0], $_[2]);
}
return $qseq;
}
### wac 072001 - expland labels to 25 from 15, put single quotes around alpha labels.
sub set_answer_labels {
@albls = ();
if ($_[0] eq 'a') {
push @albls, ('a','b','c','d','e','f','g','h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y');
} elsif ($_[0] eq 'A') {
push @albls, ('A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y');
} elsif ($_[0] eq 'n') {
push @albls, (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25);
} elsif ($_[0] eq 'r') {
push @albls, (i,ii,iii,iv,v,vi,vii,viii,ix,x,xi,xii,xiii,xiv,xv,xvi,xvii,xviii,xix,xx,xxi,xxii,xxiii,xxiv,xxv);
} elsif ($_[0] eq 'R') {
push @albls, (I,II,III,IV,V,VI,VII,VIII,IX,X,XI,XII,XIII,XIV,XV,XVI,XVII,XVIII,XIX,XX,XXI,XXII,XXIII,XXIV,XXV);
}
return @albls;
}
sub get_label_index {
@albls = ();
if ($_[0] eq 'a') {
push @albls, ('a','b','c','d','e','f','g','h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y');
} elsif ($_[0] eq 'A') {
push @albls, ('A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y');
} elsif ($_[0] eq 'n') {
push @albls, (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25);
} elsif ($_[0] eq 'r') {
push @albls, (i,ii,iii,iv,v,vi,vii,viii,ix,x,xi,xii,xiii,xiv,xv,xvi,xvii,xviii,xix,xx,xxi,xxii,xxiii,xxiv,xxv);
} elsif ($_[0] eq 'R') {
push @albls, (I,II,III,IV,V,VI,VII,VIII,IX,X,XI,XII,XIII,XIV,XV,XVI,XVII,XVIII,XIX,XX,XXI,XXII,XXIII,XXIV,XXV);
}
$retidx = -1;
for (0 .. $#albls) {
if ($albls[$_] eq $_[1]) {
@albls = ();
return $_;
}
}
@albls = ();
return $retidx;
}
sub build_answers {
$ansrs="";
@qids = split(/&/, $SUBTEST_QUESTIONS{$_[2]});
for $iansno (1 .. $_[3]) {
@ansl = ();
$ansr="";
$QUESTION{'id'}=$qids[$iansno];
&get_question_definition($_[0], $_[1], $QUESTION{'id'});
if ($QUESTION{'qtp'} eq 'mcm' || $QUESTION{'qtp'} eq 'mcs' || $QUESTION{'qtp'} eq 'mca' || $QUESTION{'qtp'} eq 'lik') {
$forcetoend="";
$forcetolast="";
$anidx = 0;
$ansmask="";
if ($QUESTION{'qca'} ne '') {
$qca = $QUESTION{'qca'};
$qca =~ s/\r/\n/g;
$qca =~ s/\n\n/\n/g;
@qca = split(/\n/, $qca);
foreach $qca (@qca) {
if ($qca ne '') {
if ($qca =~ /all of/i ) {
$forcetoend="$anidx\=1";
}
if ($qca =~ /none of/i ) {
$forcetolast="$anidx\=1";
}
push @ansl, "$anidx\=1";
if ($ansmask eq '') {$ansmask = "<$anidx>";}
else {$ansmask = join('', $ansmask, "<$anidx>");}
$anidx++;
}
}
@qca = ();
}
if ($QUESTION{'qia'} ne '') {
$qia = $QUESTION{'qia'};
$qia =~ s/\r/\n/g;
$qia =~ s/\n\n/\n/g;
@qia = split(/\n/, $qia);
foreach $qia (@qia) {
if ($qia ne '') {
if ($qia =~ /all of/i ) {
$forcetoend="$anidx\=0";
}
if ($qia =~ /none of/i ) {
$forcetolast="$anidx\=0";
}
push @ansl, "$anidx\=0";
if ($ansmask eq '') {$ansmask = "<$anidx>";}
else {$ansmask = join('', $ansmask, "<$anidx>");}
$anidx++;
}
}
@qia = ();
}
$nans = $#ansl + 1;
if ($SUBTEST{'rnda'} eq 'Y') {
while ($ansmask ne '') {
$aidx = int(rand($nans));
if($ansmask =~ /<$aidx>/ && $aidx < $nans) {
$ansr = join('?', $ansr, $ansl[$aidx]);
$ansmask =~ s/<$aidx>//g;
}
}
} else {
for (0 .. $#ansl) {
$ansr = join('?', $ansr, $ansl[$_]);
}
}
if ($forcetoend ne '') {
$ansr =~ s/\?$forcetoend//g;
$ansr = join('?', $ansr, "$forcetoend");
}
if ($forcetolast ne '') {
$ansr =~ s/\?$forcetolast//g;
$ansr = join('?', $ansr, "$forcetolast");
}
} elsif ($QUESTION{'qtp'} eq 'mtx' || $QUESTION{'qtp'} eq 'mtr') {
if ($QUESTION{'qca'} ne '') {
$qca = $QUESTION{'qca'};
$qca =~ s/\r/\n/g;
$qca =~ s/\n\n/\n/g;
@qca = split(/\n/, $qca);
foreach $qca (@qca) {
$ansr = join('?', $ansr, $qca);
}
@qca = ();
}
} elsif ($QUESTION{'qtp'} eq 'mch') {
$anidx = 0;
$ansmask="";
if ($QUESTION{'qia'} ne '') {
$qia = $QUESTION{'qia'};
$qia =~ s/\r/\n/g;
$qia =~ s/\n\n/\n/g;
@qia = split(/\n/, $qia);
foreach (0 .. $#qia) {
$qia = $qia[$_];
if ($qia ne '') {
push @ansl, "$anidx";
if ($anidx == 0) {$ansmask = "<$anidx>";}
else {$ansmask = join('', $ansmask, "<$anidx>");}
$anidx++;
}
}
@qia = ();
}
$nans = $#ansl+1;
### ADT-01 9/02/2001 prevent right half of matching questions from scrambling
if( $TEST{'rnda'} eq 'Y' )
{
### END ADT-01 change affects surveys only
$ansr=$QUESTION{'qalb'};
while ($ansmask ne '') {
$aidx = int(rand($nans));
if($ansmask =~ /<$aidx>/ && $aidx < $nans) {
$ansr = join('.', $ansr, $ansl[$aidx]);
$ansmask =~ s/<$aidx>//g;
}
}
### ADT-02 9/02/2001
}
else
{
### DED-01 7/16/2002 Added line below to include
### label in answer ("a","n", or "r")
$ansr=$QUESTION{'qalb'};
for( 0 .. $#ansl )
{
$ansr = join( '.', $ansr, $ansl[$_] );
}
}
### END ADT-02 9/02/2001
} elsif ($QUESTION{'qtp'} eq 'ord') {
$anidx = 0;
$ansmask="";
if ($QUESTION{'qca'} ne '') {
$qca = $QUESTION{'qca'};
$qca =~ s/\r/\n/g;
$qca =~ s/\n\n/\n/g;
@qca = split(/\n/, $qca);
foreach $qca (@qca) {
if ($qca ne '') {
push @ansl, "$anidx";
if ($anidx == 0) {$ansmask = "<$anidx>";}
else {$ansmask = join('', $ansmask, "<$anidx>");}
$anidx++;
}
}
@qca = ();
}
$nans = $#ansl+1;
###wac v
if( $SUBTEST{'rnda'} eq 'Y' )
{
###wac ^
### DED-02 7/16/2002 Replaced
# $ansr="o";
### with
$ansr=$QUESTION{'qalb'};
### to place label in answer ("a","n", or "r")
while ($ansmask ne '') {
$aidx = int(rand($nans));
if($ansmask =~ /<$aidx>/ && $aidx < $nans) {
$ansr = join('.', $ansr, $ansl[$aidx]);
$ansmask =~ s/<$aidx>//g;
}
}
###wac v
}
else
{
### DED-03 7/16/2002 Added line below to include
### label in answer ("a","n", or "r")
$ansr=$QUESTION{'qalb'};
for( 0 .. $#ansl )
{
$ansr = join( '.', $ansr, $ansl[$_] );
}
}
# }
###wac ^
} elsif ($QUESTION{'qtp'} eq 'nrt') {
$ansr = "";
### sac v multianswer esa support
} elsif ($QUESTION{'qtp'} eq 'esa') {
$ansr = $QUESTION{'qca'};
$ansr =~ s/\r/\n/g;
$ansr =~ s/\n\n/\n/g;
$ansr =~ s/\n/\;/g;
### sac ^ multianswer esa support
} else{
$ansr = $QUESTION{'qca'};
}
$scwght = ($QUESTION{'wght'} eq '') ? '1' : $QUESTION{'wght'};
$scpts = ($QUESTION{'pts'} eq '') ? '1' : $QUESTION{'pts'};
$scded = ($QUESTION{'ded'} eq '') ? '0' : $QUESTION{'ded'};
$scoring = join(':', $QUESTION{'subj'}, $scwght, $scpts, $scded);
$ansr = join('::', $ansr, $scoring);
$ansrs = join('&', $ansrs, $ansr);
}
@ansl = ();
@qids = ();
return $ansrs;
}
sub build_question_pool {
@qtpool = ();
@qcountrecs = &get_question_list($_[0],$_[1]);
@qcountflds = split(/&/, $qcountrecs[0]);
push @qtpool, $qcountrecs[0];
for (1 .. $#qcountflds) {
$qcountfldidx = $_;
last if($qcountflds[$_] eq 'qil');
}
for (1 .. $#qcountrecs) {
@qcountflds = split(/&/, $qcountrecs[$_]);
if ($qcountflds[$qcountfldidx] ne 'Y') {
push @qtpool, $qcountrecs[$_];
}
}
@qcountrecs = ();
@qcountflds = ();
return @qtpool;
}
sub build_rndqseq{
#print STDERR "RNDQSEQ\n";
# randomize
@qpool = &build_question_pool($_[0],$_[1]);
$qrec="";
$nqpool = $#qpool;
$qlimit = ($nqpool > $_[2]) ? $_[2] : $nqpool;
for $i (1 .. $qlimit) {
$qrec = join('&', $qrec, "<$i>");
}
for $ibrs (1 .. $qlimit) {
$qidx = int(rand($#qpool));
$qidx++;
($qid,$trash) = split(/&/, $qpool[$qidx]);
$qrec =~ s/<$ibrs>/$qid/g;
if ($qidx == $#qpool) {
pop(@qpool);
} else {
$qpool[$qidx] = pop(@qpool);
}
}
@qpool = ();
return $qrec;
}
sub build_stdqseq {
@qpool = &build_question_pool($_[0],$_[1]);
$qrec="";
$nqpool = $#qpool;
$qlimit = ($nqpool > $_[2]) ? $_[2] : $nqpool;
for $ibrs (1 .. $qlimit) {
($qid,$trash) = split(/&/, $qpool[$ibrs]);
$qrec = join('&', $qrec, $qid);
}
@qpool = ();
return $qrec;
}
sub build_formqseq {
### DED 6/11/04 build test from form file
### may later add formid as 3rd parameter to pick which form
my ($test, $clid) = @_;
open(FORMFILE, "<$questionroot/$test.$clid.form") or die "Can't open $questionroot/$test.$clid.form\n";
my @forminfo = <FORMFILE>;
close(FORMFILE);
shift @forminfo;
### DED 6/11/04 for now only use first form in file
my ($formid, $quesnos) = split(/\&/, $forminfo[0]);
my @quesnos = split(/,/,$quesnos);
$qrec="";
foreach $ques (@quesnos) {
$qid = sprintf("%s.%03u", $test, $ques);
$qrec = join('&', $qrec, $qid);
}
return $qrec;
}
sub admin_testresults {
my $registrar = $_[1];
my $adminbody = "";
if ((!$registrar && $TEST{'emlesaopt'} eq 'Y' && $TEST{'emlesahtmlopt'} eq 'Y') || ($registrar && $TEST{'emlesaropt'} eq 'H')) {
# Prepare HTML attachment
$trtime = $mmtime;
$trtime =~ s/ /_/g;
my $html = `./testreport.pl $FORM{'tid'} $SESSION{'clid'} $SESSION{'uid'} $TEST{'id'} $trtime "$results[0]" $results[1] $TEST{'noq'} $results[2]`;
$htmlfile = "$SESSION{'clid'}.$SESSION{'uid'}.$TEST{'id'}.htm";
$adminbody = "${mm_encoded_html}\n" ;
$adminbody .= encode_base64($html) ;
} else {
@testqs = &get_question_list($TEST{'id'}, $SESSION{'clid'});
$mmflds = $testqs[0];
chop($mmflds);
$mmidx = 0;
@mmflds = split(/&/, $mmflds);
for (0 .. $#mmflds) {
$mmidx = ($mmflds[$_] eq 'qtx') ? $_ : 0;
last if ($mmidx != 0);
}
@mmflds = ();
for (1 .. $#testqs) {
$testqs = $testqs[$_];
chop ($testqs);
($mmqid, $trash) = split(/&/, $testqs);
$MMQUESTION{$mmqid} = $testqs;
}
@testqs = ();
@mmqs = split(/&/, $SUBTEST_QUESTIONS{$_[0]});
@mmas = split(/&/, $SUBTEST_RESPONSES{$_[0]});
$mmfullbody = "${mm_7bit_test}\n\nRESPONSES:\n\n";
for ( 1.. $#mmas) {
$testqs = $MMQUESTION{$mmqs[$_]};
@mmflds = split(/&/, $testqs);
$mmfullbody = join('', $mmfullbody, "$_:$mmqs[$_]\n");
$mmfullbody = join('', $mmfullbody, "Q: $mmflds[$mmidx]\n");
$qqans = $mmas[$_];
$qqans = unmunge($qqans);
$mmfullbody = join('', $mmfullbody, "R: $qqans\n\n");
}
@mmflds = ();
@mmqs = ();
@mmas = ();
$mmfullbody =~ s/xxx/yyy/g;
$adminbody = join('', $adminbody, $mmfullbody);
}
return $adminbody;
}
sub send_testresults {
$logfile = "$SESSION{'clid'}.$SESSION{'uid'}";
@loglines = get_log($logfile);
@results = split(/&/, $SUBTEST_SUMMARY{$_[0]});
@startlines = grep( /Test Start/,@loglines);
($starttime, $startsession, $startnum, $startmsg) = split(/,/,@startlines[$#startlines]);
if ($_[1]) {
$mmtime = $_[1];
} else {
$mmtime = &format_date_time("dd-mmm-yyyy hh:nn:ss GMT", 1, "0");
}
if ($_[2]) {
$mmdate = $_[2];
$user_only = 1;
} else {
$mmdate = &format_date_time("dd-mmm-yyyy", 1, "0");
$user_only = 0;
}
$mmfrom = $CLIENT{'email_from'};
### Compute score
if ($TEST{'scr'} eq '3') {
$mmscore = "***** Not Scored *****\n\n";
}
##wac v 01/03/02 change wording if scoring is by cummulative points
elsif ($SUBTEST{'scr'} eq '2') {
$minpass = ($SUBTEST{'minpass'} eq "") ? "Not Specified" : $SUBTEST{'minpass'}." \points";
$mmscore = "
Points from Correct Answers: $results[0]
Points deducted for Incorrect Answers: $results[1]
Total Number of Questions: $TEST{'noq'}
Cummulative Score: $results[2] \points
Passing Score: $minpass
";
##wac v 01/08/02 change wording if scoring is by weighted percentage
} elsif ($SUBTEST{'scr'} eq '1') {
$minpass = ($SUBTEST{'minpass'} eq "") ? "Not Specified" : $SUBTEST{'minpass'}." \%";
$mmscore = "
Points (total) for Correct Answers: $results[0]
Points (total) for Incorrect Answers: $results[1]
Total Number of Questions: $TEST{'noq'}
Score: $results[2] \%
Passing Score: $minpass
";
} else {
$minpass = ($SUBTEST{'minpass'} eq "") ? "Not Specified" : $SUBTEST{'minpass'}." \%";
$mmscore = "
Correct Answers: $results[0]
Incorrect Answers: $results[1]
Total Number of Questions: $TEST{'noq'}
Score: $results[2] \%
Passing Score: $minpass
";
}
# Compute the email boundary string used to divide multi-part
# email messages.
my $myrand ;
my $rand_str ;
my $boundary_str = "Acts-Corp-Boundary-" ;
foreach $i (1..5) {
$myrand = rand ;
$rand_str = sprintf "%12.12f", $myrand ;
$rand_str =~ s/^0\.// ;
$boundary_str .= $rand_str ;
}
$MIME_start = "MIME-version: 1.0\n" ;
$MIME_start .= "Content-Type: multipart/mixed; boundary=" ;
$MIME_start .= "\"${boundary_str}\"\n\n" ;
$mm_7bit_text = "\n--${boundary_str}\n" ;
$mm_7bit_text .= "Content-type: text/plain\n" ;
$mm_7bit_text .= "Content-transfer-encoding: 7bit\n" ;
$mm_encoded_html = "\n--${boundary_str}\n" ;
$mm_encoded_html .= "Content-type: text/html\n" ;
$mm_encoded_html .= "Content-transfer-encoding: base64\n" ;
if (!$user_only) {
### Send results to admin notification list
$mmto = $TEST{'ntfy'};
$mmsubj = "Completed: $CANDIDATE{'nmf'} $CANDIDATE{'nml'}";
$mmnoreply = "DO NOT REPLY TO THIS MESSAGE";
$mmheader = "
Date: $mmdate
Site: $TEST_SESSION{'clid'}
Candidate: $SESSION{'uid'}
Name: $CANDIDATE{'nmf'} $CANDIDATE{'nml'}
Description: $TEST{'desc'} - $TEST{'id'}
Start Time: $starttime
Compl Time: $mmtime
";
$mmbody = join('', ${MIME_start}, ${mm_7bit_text}, $mmnoreply, $mmheader, $mmscore);
### Send notification to admin distribution list
if ($mmto ne '') {
my $adminbody = $mmbody;
if ($TEST{'emlesaopt'} eq 'Y') {
my $admin_testresults = &admin_testresults($_[0],0);
$adminbody = join('', $adminbody, $admin_testresults);
$mmorder = "\n$SUBTEST_ANSWERS{$_[0]}\n";
$adminbody = join('', $adminbody, ${mm_7bit_text}, $mmorder);
}
&send_mail($mmfrom, $mmto, $mmsubj, $adminbody);
}
# HBI Defect - %CLIENT is not populated, So $CLIENT{'clid'} is empty.
# HBI Defect - The code should call get_client_profile($TEST_SESSION{'clid'}) to populate %CLIENT.
# HBI Defect - get_client_profile is in cybertestlib.pl.
### Is there a registrar?
if ($TEST{'emlesaropt'} ne 'N' && &get_a_key("cnd.$CLIENT{'clid'}", $CANDIDATE{'createdby'}, "registrar") eq 'Y') {
### Does registrar have an e-mail address?
$mmto = &get_a_key("cnd.$CLIENT{'clid'}", $CANDIDATE{'createdby'}, "eml");
if ($mmto ne '') {
my $notifbody = $mmbody;
### Send notification to registrar
if ($TEST{'emlesaropt'} eq 'H') {
my $admin_testresults = &admin_testresults($_[0],1);
$notifbody = join('', $MIME_start, $mm_7bit_text, $notifbody);
$notifbody .= join('', $admin_testresults);
$mmorder = "\n$SUBTEST_ANSWERS{$_[0]}\n";
$notifbody .= join('', $mm_7bit_text, $mmorder);
}
&send_mail($mmfrom, $mmto, $mmsubj, $notifbody);
}
}
} # END if (!$user_only)
if ($TEST{'emlcndopt'} eq 'Y') {
### Send results to candidate
$mmto = $CANDIDATE{'eml'};
$mmsubj = "Final results - $CANDIDATE{'nmf'} $CANDIDATE{'nml'}";
$mmbody = "DO NOT REPLY TO THIS MESSAGE
Date: $mmdate
Site: $TEST_SESSION{'clid'}
Candidate: $CANDIDATE{'uid'}
Name: $CANDIDATE{'nmf'} $CANDIDATE{'nml'}
Description: $TEST{'desc'} - $TEST{'id'}
The test administrator has been notified of your test scores as shown below.
Candidate completed the item above at $mmtime on the specified date with the following results.
$mmscore
";
##wac 01/03/02 - added one line above - $mmscore. Idea is to pick up wording for results from above, should still be in $mmscore
#Correct Answers: $results[0]
#Incorrect Answers: $results[1]
#Total Number of Questions: $TEST{'noq'}
#Score: $results[2] \%\n";
##wac ^
if ($mmto ne '') {
&send_mail($mmfrom, $mmto, $mmsubj, $mmbody);
}
}
}
sub send_start_notification {
$mmdate = &format_date_time("dd-mmm-yyyy", "1", "0");
$mmtime = &format_date_time("hh:nn:ss GMT", "1", "0");
$mmfrom = $CLIENT{'email_from'};
if ($_[0] ne '') {
$mmto = $_[0];
} else {
$mmto = $TEST{'ntfy'};
}
$mmsubj = "Activity Initiated: $CANDIDATE{'nmf'} $CANDIDATE{'nml'}";
$mmbody = "DO NOT REPLY TO THIS MESSAGE
Date: $mmdate
Candidate: $SESSION{'uid'}
Site: $TEST_SESSION{'clid'}
Name: $CANDIDATE{'nmf'} $CANDIDATE{'nml'}
Description: $TEST{'desc'} - $TEST{'id'}
Candidate has started the above item at $mmtime on this date.
";
&send_mail($mmfrom, $mmto, $mmsubj, $mmbody);
}
sub send_resume_notification {
$mmdate = &format_date_time("dd-mmm-yyyy", "1", "0");
$mmtime = &format_date_time("hh:nn:ss GMT", "1", "0");
$mmfrom = $CLIENT{'email_from'};
if ($_[0] ne '') {
$mmto = $_[0];
} else {
$mmto = $TEST{'ntfy'};
}
$mmsubj = "Activity Resumed: $CANDIDATE{'nmf'} $CANDIDATE{'nml'}";
$mmbody = "DO NOT REPLY TO THIS MESSAGE
Date: $mmdate
Candidate: $SESSION{'uid'}
Site: $TEST_SESSION{'clid'}
Name: $CANDIDATE{'nmf'} $CANDIDATE{'nml'}
Description: $TEST{'desc'} - $TEST{'id'}
Candidate has resumed the above item at $mmtime on this date.
";
&send_mail($mmfrom, $mmto, $mmsubj, $mmbody);
}
sub send_pause_notification {
$mmdate = &format_date_time("dd-mmm-yyyy", "1", "0");
$mmtime = &format_date_time("hh:nn:ss GMT", "1", "0");
$mmfrom = $CLIENT{'email_from'};
if ($_[0] ne '') {
$mmto = $_[0];
} else {
$mmto = $TEST{'ntfy'};
}
if ($TEST{'seq'} eq 'svy' || $TEST{'seq'} eq 'dmg') {
$itemdescription = "Survey";
} else {
$itemdescription = "Test";
}
$mmsubj = "$itemdescription Paused: $CANDIDATE{'nmf'} $CANDIDATE{'nml'}";
$mmbody = "DO NOT REPLY TO THIS MESSAGE
Date: $mmdate
Site: $TEST_SESSION{'clid'}
Candidate: $SESSION{'uid'}
Name: $CANDIDATE{'nmf'} $CANDIDATE{'nml'}
Description: $TEST{'desc'} - $TEST{'id'}
Candidate Paused the above item at $mmtime on this date.
";
&send_mail($mmfrom, $mmto, $mmsubj, $mmbody);
}
sub send_declined_notification {
$mmdate = &format_date_time("dd-mmm-yyyy", "1", "0");
$mmtime = &format_date_time("hh:nn:ss GMT", "1", "0");
$mmfrom = $CLIENT{'email_from'};
$mmto = $TEST{'ntfy'};
$mmsubj = "CONFIDENTIALITY DECLINED: $CANDIDATE{'nmf'} $CANDIDATE{'nml'}";
$mmbody = "DO NOT REPLY TO THIS MESSAGE
Date: $mmdate
Site: $TEST_SESSION{'clid'}
Candidate: $SESSION{'uid'}
Name: $CANDIDATE{'nmf'} $CANDIDATE{'nml'}
Description: $TEST{'desc'} - $TEST{'id'}
Candidate declined the confidentality agreement at $mmtime on this date.
The item above was terminated and unregistered.
";
# The following email has all text, and should not need multipart lines.
&send_mail($mmfrom, $mmto, $mmsubj, $mmbody);
}
#
# &show_test_worksheets($TEST_SESSION{'clid'}, $TEST_SESSION{'id'})
#
sub show_test_worksheets {
@pagenos = split(/\./, $TEST{'Ins'});
$pagecount = $#pagenos + 1;
# show test instructions
$jvars = "";
$jscript = "i=1\;\nimax=$pagecount\;\n\n";
$buttons = "";
$jointer="";
for (0 .. $#pagenos) {
$x = int($_) + 1;
$fpath = join($pathsep,$questionroot,"Ins","$TEST{'id'}.$SESSION{'clid'}.$pagenos[$_]");
$wsURL = "$cgiroot/twsprint.pl?tid=$SESSION{'tid'}\&fn=$fpath";
$jvars = join($jointer, $jvars, "wdw$x,sWorksheet$x");
$jscript = join('', $jscript, "sWorksheet$x=\"$wsURL\"\;\n");
$tmptitle = &get_test_worksheet($TEST{'id'},$SESSION{'clid'},$pagenos[$_]);
@tmphtml = split(/<TITLE>/, $tmptitle);
$tmptitle = $tmphtml[1];
@tmphtml = split(/<\/TITLE>/, $tmptitle);
$tmptitle = ($tmphtml[0] eq '') ? "Worksheet $x" : "$tmphtml[0]";
if ($SESSION{'browserapp'} eq 'MSIE') {
$buttons = join('', $buttons, "<INPUT TYPE=BUTTON VALUE=\"Reprint $tmptitle\" onClick=\"return Reprintpage($x)\"><BR>\n");
} else {
$buttons = join('', $buttons, "<INPUT TYPE=BUTTON VALUE=\"Print $tmptitle\" onClick=\"return Reprintpage($x)\"><BR>\n");
}
$jointer=",";
}
$FORM{'jscript'} = join('', "var $jvars\;\n", $jscript);
$FORM{'buttons'} = $buttons;
&show_template("qins");
}
# sac - start addition for subject area percentage support
sub IsTestSBA {
my ($clid, $tstid) = @_;
my $said;
my $skid;
my $saskcount;
my $fn = join( $pathsep, $questionroot, "$tstid.$clid.sba.mtx");
my $bOK=0;
$SUBTEST{'IsTestSBA'}=0;
if (open(TMPFILE, "<$fn")) {
my @sbarecs = <TMPFILE>;
close TMPFILE;
if ($#sbarecs == 2) {
chop $sbarecs[0];
chop $sbarecs[1];
chop $sbarecs[2];
my @samtxrecs=split(/\,/,$sbarecs[2]);
if ($#samtxrecs != -1) {
($said,$skid,$saskcount) = split(/\:/,$samtxrecs[0]);
if (($said ne '') && ($skid ne '') && ($saskcount ne '')) {
$SUBTEST{'IsTestSBA'} = -1;
$SUBTEST{'sbausesubj'} = $sbarecs[0];
$SUBTEST{'sbauseskill'} = $sbarecs[1];
$SUBTEST{'sbamtx'} = $sbarecs[2];
$bOK=-1;
}
}
}
}
return $bOK;
}
sub build_rndqseq_sba {
#print STDERR "RNDQSEQ_SBA\n";
my ($tstid, $clid, $tnoq) = @_;
# randomize
my $i;
my $j;
my $qrec="";
my $qrecall="";
my $nqpool=0;
my $qlimit=0;
my @flds;
my $ibrs;
my $qidx;
my $trash;
my $sasksubj;
my $saskskill;
my $saskcount;
my $saskqtotal=0;
my @qpool = ();
my $sgrepfor="";
my $nm;
my $pct;
my $rnd;
my $fixord;
my %sarnds;
my %safxos;
my %sapools;
# Debug ANALYSIS
#if ($SUBTEST{'rndq'} eq "Y") { print STDERR "on\n"; } else { print STDERR "off\n";}
# reset the error indicator
$SYSTEM{'testpreperror'}="";
# get the question list excluding obsolete questions
my @qpoolmaster = &build_question_pool($tstid,$clid);
@flds = split(/&/, $qpoolmaster[0]);
for $i (0 ..$#flds) {
if ($flds[$i] eq 'subj') {
$j=$i;
$qpoolmaster[0] = join('&', $flds[0], "$flds[$j]");
}
}
for $i (1 ..$#qpoolmaster) {
@flds = split(/&/, $qpoolmaster[$i]);
if ($flds[$j] =~ /\./ ) {
$qpoolmaster[$i] = join('&', $flds[0], "$flds[$j]");
} else {
$qpoolmaster[$i] = join('&', $flds[0], "$flds[$j].0");
}
}
#
# build subject area parameters array
# %sarnds randomization flags
# %safxos fixed orders
# %sapools accumulated questions for all subj skill levels
#
my @saparms=split(/\,/,$SUBTEST{'sbausesubj'});
for $i (0 .. $#saparms) {
if ($saparms[$i] ne '') {
($nm,$pct,$rnd,$fixord) = split(/:/, $saparms[$i]);
$sarnds{$nm}=int($rnd);
$safxos{$nm}=int($fixord);
$sapools{$nm}="";
}
}
@saparms=();
# build subject skill array from $SUBTEST{'sbamtx'}
my @sasks = split(/\,/, $SUBTEST{'sbamtx'});
$j=$#sasks+1;
# for subject area create the question pools
# and name the index in qspool array
my @qspool;
$j=-1;
for $i (0 .. $#sasks) {
($sasksubj,$saskskill,$saskcount) = split(/\:/,$sasks[$i]);
if (($sasksubj eq '') || ($saskskill eq '') || ($saskcount eq '')) {
# file format error
$SYSTEM{'testpreperror'}="Unable to prepare $tstid: subject area skill level matrix format error.";
} else {
# prepare the question pool for the subject area
my $sklvlid=($saskskill eq 'BASIC') ? "0" : "";
$sklvlid=($saskskill eq 'INTERMEDIATE') ? "1" : $sklvlid;
$sklvlid=($saskskill eq 'ADVANCED') ? "2" : $sklvlid;
#
$sgrepfor=join('.',"\&$sasksubj","$sklvlid");
@qpool = grep( /$sgrepfor/,@qpoolmaster);
#
# prepare the sequential or randomized question list
# and merge all skill levels for each subject area
#
$qrec="";
unshift @qpool,$qrec;
$nqpool = $#qpool;
if ($nqpool >= $saskcount) {
if (($sarnds{$sasksubj} == 1) || ($SUBTEST{'rndq'} eq 'Y')) {
$qrec=&randomize_qpool($saskcount,@qpool);
} else {
$qrec=&sequential_qpool($saskcount,@qpool);
}
$sapools{$sasksubj}=join('', $sapools{$sasksubj}, $qrec);
if (($qspool[$j] ne $sasksubj) || ($j == -1)) {
$j++;
$qspool[$j]=$sasksubj;
}
} else {
# Insufficient question count to meet required distribution
$SYSTEM{'testpreperror'}="Unable to prepare $tstid:<br>Insufficient number of $sasksubj.$saskskill questions in the pool.<br>$saskcount required : $nqpool defined and active.<br>";
}
@qpool = ();
}
}
@sasks=();
@qpoolmaster=();
if ($SYSTEM{'testpreperror'} eq '') {
#
# if there were no errors
#
if ($SUBTEST{'rndq'} eq 'Y') {
#
# if globally randomized combine the pools and randomize
#
$qrec="";
for $i (0 .. $#qspool) {
$sasksubj=$qspool[$i];
$qrec=join('',$qrec,$sapools{$sasksubj});
}
@qpool=split(/&/,$qrec);
$saskcount=$#qpool;
$qrecall=&randomize_qpool($saskcount,@qpool);
@qpool=();
} else {
#
# keep subject area together and randomization within
#
for $i (0 .. $#qspool) {
$sasksubj=$qspool[$i];
if ($sarnds{$sasksubj} == 0) {
@qpool=split(/&/,$sapools{$sasksubj});
$saskcount=$#qpool;
@qpool=();
} else {
@qpool=split(/&/,$sapools{$sasksubj});
$saskcount=$#qpool;
$sapools{$sasksubj}=&randomize_qpool($saskcount,@qpool);
@qpool=();
}
}
#
# check for fixed order and randomize the others
#
my @sbjfixed=();
my @sbjrndmz=();
for $i (0 .. $#qspool) {
$sasksubj=$qspool[$i];
if ($safxos{$sasksubj} == 0) {
push @sbjrndmz, $sasksubj;
} else {
$qrec="$safxos{$sasksubj}.$sasksubj";
push @sbjfixed,$qrec;
}
}
if ($#sbjrndmz != -1) {
$qrec="";
unshift @sbjrndmz, $qrec;
$saskcount=$#sbjrndmz;
$qrec=&randomize_qpool($saskcount,@sbjrndmz);
@sbjrndmz=split(/&/,$qrec);
$qrec=shift @sbjrndmz;
}
if ($#sbjfixed != -1) {
@qpool = sort @sbjfixed;
@sbjfixed = @qpool;
@qpool = ();
}
#for $i (0 .. $#sbjrndmz) {
#}
#for $i (0 .. $#sbjfixed) {
#}
@qspool=();
if (($#sbjrndmz != -1) && ($#sbjfixed != -1)) {
$saskcount=$#sbjrndmz + $#sbjfixed + 2;
$qrec=shift @sbjfixed;
($j,$sasksubj) = split(/\./,$qrec);
for $i ( 1 .. $saskcount) {
if( $i == $j) {
push @qspool, $sasksubj;
if ($#sbjfixed == -1) {
$sasksubj="";
$j=0;
} else {
$qrec=shift @sbjfixed;
($j,$sasksubj) = split(/\./,$qrec);
}
} else {
if ($#sbjrndmz != -1) {
$qrec=shift @sbjrndmz;
push @qspool, $qrec;
}
}
}
if ($sasksubj ne '') {
push @qspool, $sasksubj;
$j=1000;
while (($#sbjfixed != -1) && ($j > 0)) {
$qrec=shift @sbjfixed;
($j,$sasksubj) = split(/\./,$qrec);
push @qspool, $sasksubj;
$j--;
}
}
#for $i (0 .. $#qspool) {
#}
} else {
### DED 11/02/2002 Changed
#if ($#sbjfixed != -1) {
### to
if ($#sbjrndmz != -1) {
@qspool = @sbjrndmz;
} else {
@qspool = @sbjfixed;
}
}
@sbjfixed=();
@sbjrndmz=();
$qrecall="";
for $i (0 .. $#qspool) {
$sasksubj = $qspool[$i];
$qrecall=join('',$qrecall,$sapools{$sasksubj});
}
}
}
@qspool=();
%sarnds={};
%safxos={};
%sapools={};
# ANALYSIS
#@qpool=split(/&/,$qrecall);
#@qpool=();
return $qrecall;
}
sub randomize_qpool {
my ($qlmt,@qp) = @_;
my $i;
my $j;
my $nqp;
my $qid;
my $trash;
my $ibrs;
my $qidx;
my $qrec="";
for $i (1 .. $qlmt) {
$qrec = join('&', $qrec, "<$i>");
}
for $ibrs (1 .. $qlmt) {
$qidx = int(rand($#qp));
$qidx++;
($qid,$trash) = split(/&/, $qp[$qidx]);
$qrec =~ s/<$ibrs>/$qid/g;
if ($qidx == $#qp) {
pop(@qp);
} else {
$qp[$qidx] = pop(@qp);
}
}
return $qrec;
}
sub sequential_qpool {
my ($qlmt,@qp) = @_;
my $i;
my $qid;
my $trash;
my $qrec="";
for $i (1 .. $qlmt) {
($qid,$trash) = split(/&/, $qp[$i]);
$qrec = join('&', $qrec, $qid);
}
return $qrec;
}
# sac - end addition for subject area percentage support
# v sac anonymous submission support
sub make_anonymous {
# test completed, terminated, or time expired
# split off the anonymous parts if permitted and requested
&get_test_sequence( $SESSION{'clid'}, $SESSION{'uid'}, $FORM{'tstid'}, $testcomplete);
my $cnt = unlink "$testcomplete/".$SESSION{'clid'}.".".$SESSION{'uid'}.".".$FORM{'tstid'};
my @anonymityFlags = split(/\;/,$SESSION{'anonymity'});
my $anonflag;
my $subtstno;
my $subtstnm;
my $subtstanon;
my $tstfile;
my $tsthistfile;
my $historyopen=0;
my $flsep="\<\<\>\>";
my $clid=$TEST_SESSION{'clid'};
my @tests=();
$tests[1]=$TEST_SESSION{'profb'};
$tests[2]=$TEST_SESSION{'id'};
$tests[3]=$TEST_SESSION{'profa'};
$tests[4]=$TEST_SESSION{'srvy'};
my @flags=split(/\,/,",N,N,N,N");
foreach $anonflag (@anonymityFlags) {
($subtstno,$subtstnm,$subtstanon) = split(/\./,$anonflag);
$flags[$subtstno]=$subtstanon;
}
my $ident;
my $uid;
my $chmodOK;
my $dscl=$TEST_SESSION{'dscl'};
for $i (1 .. 4) {
if ($tests[$i] ne "") {
if ($flags[$i] eq 'Y') {
$uid=&get_anon_seqno($clid,$tests[$i]);
} else {
$uid=$TEST_SESSION{'uid'};
}
$tstfile=join($pathsep, $testcomplete, "$clid.$uid.$tests[$i]");
$ident=$clid;
$ident=join('&',$ident,$uid);
$ident=join('&',$ident,$tests[$i]);
$ident=join('&',$ident,$TEST_SESSION{'state'});
if ($i == 2) {
$ident=join('&',$ident,$dscl);
} else {
$ident=join('&',$ident,"");
}
$ident=join('&',$ident,"");
$ident=join('&',$ident,$tests[$i]);
$ident=join('&',$ident,"");
$ident=join('&',$ident,"");
$ident=join('&',$ident,$TEST_SESSION{'ntfy'});
$ident=join('&',$ident,$TEST_SESSION{'emlcnd'});
if (open(TOFILE, ">$tstfile")) {
print TOFILE "$ident\n";
print TOFILE "\n\n\n\n";
print TOFILE "$SUBTEST_QUESTIONS{$i}\n";
print TOFILE "$SUBTEST_ANSWERS{$i}\n";
print TOFILE "$SUBTEST_RESPONSES{$i}\n";
print TOFILE "$SUBTEST_SUMMARY{$i}\n";
print TOFILE "\n\n\n\n";
print TOFILE "\n\n\n\n";
close TOFILE;
$chmodOK = chmod 0666,$tstfile;
}
$logfile = "$SESSION{'clid'}.$SESSION{'uid'}";
# DED 1/03/04 no longer puting starttime in history file
#@loglines = get_log($logfile);
#@startlines = grep( /Test Start/,@loglines);
#($starttime, $startsession, $startnum, $startmsg) = split(/,/,@startlines[$#startlines]);
$tsthistfile=join($pathsep, $testcomplete, "$clid.$tests[$i].history");
if (open(TOFILE, ">>$tsthistfile")) {
$historyopen=1;
} else {
if (open(TOFILE, ">$tsthistfile")) {
$historyopen=1;
} else {
$historyopen=0;
}
}
if ($historyopen) {
print TOFILE "$endtime$flsep";
print TOFILE "$ident$flsep";
print TOFILE "$SUBTEST_QUESTIONS{$i}$flsep";
print TOFILE "$SUBTEST_ANSWERS{$i}$flsep";
print TOFILE "$SUBTEST_RESPONSES{$i}$flsep";
print TOFILE "$SUBTEST_SUMMARY{$i}\n";
}
close TOFILE;
$chmodOK = chmod 0666,$tsthistfile;
}
}
}
sub get_anon_seqno {
my ($clid,$testid) = @_;
my $sgrepfor;
my $entry;
my $cnt;
my $iter;
my $uid;
my @dots=();
my @dots2=();
my @entries=();
my @segs=();
my $nxtid="anon";
my @clsegs=split(/\./,$clid);
my $tstclid="";
opendir(DIR, $testcomplete);
@dots = readdir(DIR);
closedir DIR;
opendir(DIR, $testinprog);
@dots2 = readdir(DIR);
closedir DIR;
push @dots, @dots2;
$cnt=0;
if ($#dots != -1) {
$sgrepfor=join('.',"$clid","anon","\*","$testid");
@entries = grep( /$sgrepfor/,@dots);
@dots = ();
$cnt=0;
foreach $entry (@entries) {
@segs=split(/\./, $entry);
$tstclid="";
for (0 .. $#clsegs) {
$tstclid=join('.',$tstclid,$segs[$_]);
}
### DED 3/23/04 Must trim leading "." from tstclid
$tstclid=substr($tstclid,1);
if (($tstclid eq $clid) && ($segs[$#segs] eq $testid)) {
if ($cnt < $segs[2]) {
$cnt = $segs[2];
}
}
}
}
$cnt++;
$nxtid=join('.','anon',"$cnt");
return $nxtid;
}
# ^ sac anonymous submission support
sub get_test_sequence_for_reports {
# Called with $CLIENT{'clid'},$FORM{'cndid'}, $FORM{'tstid'}
# The pupose of this routine is to populate the global associative
# arrays: TEST_SESSION SUBTEST_QUESTIONS SUBTEST_ANSWERS SUBTEST_RESPONSES SUBTEST_SUMMARY
&get_test_profile($_[0], $_[2]);
# populates the Assoc. array %TEST with the characteristics of the test (but not the questions or answers).
$trash3 = join($pathsep, $testcomplete, "$_[0].$_[1].$_[2]");
$msg = "";
if ( ! open(TESTFILE,"<$trash3") ) {
&logger::logerr("Unable to open $trash3: $!");
$msg="failed";
print "<!-- open failure\n$trash3\n$!\n-->\n";
$msg = "";
# Clear the hashs. Otherwise the calling code will process the current contents.
%TEST_SESSION = () ;
%SUBTEST_QUESTIONS = () ;
%SUBTEST_ANSWERS = () ;
%SUBTEST_RESPONSES = () ;
%SUBTEST_SUMMARY = () ;
} else {
@seqlines = <TESTFILE>;
close TESTFILE;
$isubtest = 1; $iidx = 0; $iaryidx = 1;
foreach $seqline (@seqlines) {
chop ($seqline);
if ($iidx eq 0) {
# Process the first line of the Candidates test.
@status = split(/&/, $seqline);
$ifld = 0;
$TEST_SESSION{'clid'} = $status[$ifld++]; # Client ID, like sandbox.
$TEST_SESSION{'uid'} = $status[$ifld++]; # Candidate ID, like hank1
$TEST_SESSION{'tstid'} = $status[$ifld++]; # Test ID, like linux01
$TEST_SESSION{'state'} = $status[$ifld++]; # State, like 6.0.0 (for ???)
$TEST_SESSION{'dscl'} = $status[$ifld++];
$TEST_SESSION{'profb'} = $status[$ifld++];
$TEST_SESSION{'id'} = $status[$ifld++]; # Test ID, like linux01
$TEST_SESSION{'profa'} = $status[$ifld++];
$TEST_SESSION{'srvy'} = $status[$ifld++];
$TEST_SESSION{'ntfy'} = $status[$ifld++];
$TEST_SESSION{'emlcnd'} = $status[$ifld++]; # Email address of candidate
# Warning: The last two fields do not match the sample I looked at.
@status = ();
$iidx++;
} else {
if ($iaryidx eq 1) {
$SUBTEST_QUESTIONS{$isubtest} = $seqline;
} elsif ($iaryidx eq 2) {
$SUBTEST_ANSWERS{$isubtest} = $seqline;
} elsif ($iaryidx eq 3) {
$seqline =~ s/\%0D\%0A/<br>/g;
$SUBTEST_RESPONSES{$isubtest} = unmunge($seqline);
} elsif ($iaryidx eq 4) {
$SUBTEST_SUMMARY{$isubtest} = $seqline;
}
# The second and successive lines are treated as groups of four lines; 2-5, 6-9, etc.
$iaryidx++;
if ($iaryidx eq 5) {
$iaryidx = 1;
$isubtest++;
}
}
}
}
@seqlines = ();
return;
}
sub getPrograms {
my ($client) = @_;
my @programs = &get_data("programs.$client");
if (not @programs) {
# no programs defined
return undef;
}
chomp $programs[0];
my @fields = split(/&/,shift @programs);
my $programs={};
foreach (@programs) {
chomp $_;
my $tmp = {};
@{$tmp}{@fields} = split(/&/,$_);
$tmp->{'prglist'} = [split(/,/,$tmp->{'prglist'})];
$programs->{$tmp->{'prgid'}} = $tmp;
$tmp = {};
}
return $programs;
}
sub getGroups {
# Parameters
# $client - character string of the Client ID.
# Returned value.
# $groups is a reference to an un-named hash.
# The keys of the hash are the group (Department) ids.
# The values of the hash are other un-named hashs.
# These other un-named hashs contain data for the group (Department).
# The keys of the other hashs are the field ids in the groups file.
# The values of the other hashs are the data, as a string, for the group.
# But the value for the 'grplist' key is not a string.
# The value for the 'grplist' key is a reference to an array.
my ($client) = @_;
my @groups = &get_data("groups.$client");
if (not @groups) {
# no groups defined
return undef;
}
chomp $groups[0];
my @fields = split(/&/,shift @groups);
my $groups={};
foreach (@groups) {
chomp $_;
my $tmp = {};
@{$tmp}{@fields} = split(/&/,$_);
# @fields is the list of field ids, and the keys to the anon. hash reffed by $tmp.
my %user_ids = () ;
foreach my $user_id (split(/,/,$tmp->{'grplist'})) {
$user_ids{$user_id} = 1 ;
}
# Any user id will be listed only once.
$tmp->{'grplist'} = [ sort keys %user_ids] ;
$groups->{$tmp->{'grpid'}} = $tmp;
$tmp = {};
}
return $groups;
}
sub setGroups {
my ($client,$groups) = @_;
my @groups;
my $grpfile = join($pathsep, $dataroot, "groups.$client");
if (not &file_exists($grpfile)) {
my $grpheader = join($pathsep, $dataroot, "groups.std");
unless (&make_file( $grpfile, $grpheader, 1)) {
&log_entry($SESSION{'clid'}, $SESSION{'uid'}, "3", "FC Error: $grpfile $grpheader");
return 0;
}
}
@groups = &get_data("groups.$client");
chomp $groups[0];
my @fields = split(/&/,$groups[0]);
@groups = ($groups[0]."\n");
foreach (values %$groups) {
my @line = ();
foreach my $fld (@fields) {
if ($fld eq 'grplist') {
push @line, join(',',@{$_->{'grplist'}});
} else {
push @line, $_->{$fld};
}
}
push @groups, join('&',@line)."\n";
}
open(TMPGRP, ">".join($pathsep, $dataroot, "groups.$client")) or return 0;
print TMPGRP @groups;
close TMPGRP;
return 1;
}
sub getIdlist {
# Parameters
# $client - Client id as a string.
# $grplist - string with comma separated group ids.
# Returned value
# $idlist is an un-named hash.
# The keys of the hash are the candidates in the groups.
# The values of the hash are 1.
my ($client,$grplist) = @_;
my $idlist;
my $groups = &getGroups($client);
foreach my $grp (split(/,/,$grplist)) {
foreach my $cnd (@{$groups->{$grp}->{'grplist'}}) {
$idlist->{$cnd} = 1;
}
}
return $idlist;
}
sub getGroupMemberships {
my ($client) = @_;
my $groups = &getGroups($client);
my $canidates = {};
foreach my $group (keys %$groups) {
foreach my $canidate (@{$groups->{$group}->{'grplist'}}) {
push @{$canidates->{$canidate}}, $group;
}
}
return $canidates;
}
sub get_cnd_test_from_history {
my ($dir,$clid,$cndid,$tstid,$testdate) = @_;
my $testseconds = (defined $testdate ? toGMSeconds($testdate) : undef);
my @seqlines = ();
my $test_data;
&get_test_profile($clid, $tstid);
my $trash = join($pathsep, $dir, "$clid.$tstid.history");
$msg = "";
open(TESTFILE, "<$trash") or $msg="failed to open history file";
if ($msg eq "failed") {
$msg = "";
return undef;
} else {
@seqlines = <TESTFILE>;
my $entry;
foreach (reverse @seqlines) {
my @lines = split(/\<\<\>\>/, $_);
my $timestamp = toGMSeconds($lines[0]);
my %test_data;
if (defined $testseconds and (abs($testseconds-$timestamp) > 5)) {next;}
@test_data{'clid','uid','tstid','state','dscl','profb','id','profa','srvy','ntfy','emlcnd'} =
split(/&/, $lines[1]);
if ($test_data{'uid'} ne $cndid) {undef %test_data; next;}
$test_data{'end'} = $test_data{'start'} = $timestamp;
$test_data{'SUBTEST_QUESTIONS'} = $lines[2];
$test_data{'SUBTEST_ANSWERS'} = $lines[3];
$test_data{'SUBTEST_RESPONSES'} = $lines[4];
$test_data{'SUBTEST_SUMMARY'} = $lines[5];
$test_data = \%test_data;
last;
}
}
close TESTFILE;
return $test_data;
}
sub get_cnd_test_cnt_from_history {
# Get the number of times the candidate has taken the test.
# The parameters are:
# $dir - directory that contains the history files.
# $clid - Client id.
# $cndid - Candidate id.
# $tstid - Test id.
my ($dir,$clid,$cndid,$tstid) = @_;
my @seqlines = ();
my $test_count = 0;
my $trash = join($pathsep, $dir, "$clid.$tstid.history");
$msg = "";
open(TESTFILE, "<$trash") or $msg="failed to open history file";
if ($msg eq "failed") {
$msg = "";
return undef;
}
@seqlines = <TESTFILE>;
close TESTFILE;
my $entry;
foreach (@seqlines) {
my @lines = split(/\<\<\>\>/, $_);
my %test_data;
@test_data{'clid','uid','tstid','state','dscl','profb','id','profa','srvy','ntfy','emlcnd'} =
split(/&/, $lines[1]);
if ($test_data{'uid'} eq $cndid) {$test_count++;}
}
return $test_count;
}
sub get_users {
my ($client,$test) = @_;
my @users = &get_data("cnd.$client");
chomp ($users[0]);
my @keys = split(/&/,shift(@users));
my %userdata;
foreach my $user (@users) {
chomp $user;
$userdata{substr($user,0,index($user,"&"))} = $user;
}
if (defined $test) {
my %tmp;
my @filelist = &get_test_result_files($testcomplete, $client, $test);
foreach my $file (@filelist) {
my $user = $file;
$user =~ s/.$test$//;
$user =~ s/^$client.//;
if (exists $userdata{$user}) {
$tmp{$user} = $userdata{$user};
}
}
return (\%tmp);
} else {
return (\%userdata);
}
}
sub build_number_select_list {
my ($min, $max, $step) = @_;
my $option_list = "";
if ($step eq "") {
$step = 1;
}
if ($step eq "spread") {
foreach my $i (1,5,10,20,25,50,100,250,500) {
$option_list .= "<OPTION value=$i>$i</OPTION>\n";
}
} else {
for (my $i=$min;$i<=$max;$i += $step) {
$option_list .= "<OPTION value=$i>$i</OPTION>\n";
}
}
return $option_list;
}
sub single_form_test_done {
&put_several_questions();
my $passfailflag=&summarize_test($tsubtest);
&put_test_sequence($testinprog, $TEST_SESSION{'clid'}, $TEST_SESSION{'uid'}, $TEST_SESSION{'id'});
&get_test_profile( $TEST_SESSION{'clid'}, $TEST_SESSION{'subtest'});
$TEST{'customexit'}=&check_for_custom_exit_file($passfailflag);
$tstate = $TEST_STATES{'_COMPLETED'};
$tsubtest=0; $tqno=0;
$TEST_SESSION{'state'} = "$tstate.$tsubtest.$tqno";
&put_test_sequence($testinprog, $TEST_SESSION{'clid'}, $TEST_SESSION{'uid'}, $TEST_SESSION{'id'});
&promote_test_sequence($testinprog, $testcomplete, $TEST_STATES{'_COMPLETED'});
if ($TEST{'ntfy'} ne '') {
&get_test_profile( $TEST_SESSION{'clid'}, $TEST_SESSION{'id'});
&send_testresults("2","$endtime");
}
&send_custom_exit_email($passfailflag);
$TEST_SESSION{'navbuttons'}="<INPUT TYPE=SUBMIT NAME=\"submit\" VALUE=\"$xlatphrase[769]\" onClick=\"cancel_test()\">";
&show_template($tetmplt);
}
sub put_several_questions {
# multiple questions on same page
my $tmpkey;
&get_subtest_profile( $TEST_SESSION{'clid'}, $TEST_SESSION{'subtest'});
$TEST_SESSION{'noq'}=$SUBTEST{'noq'};
if ($_[0]) {
$hitqno=$_[0];
} else {
$hitqno=0;
}
for (keys %FORM) {
if ($_ =~ /q[0-9]/ ) {
($tqno, $tqidx) = split(/\-/, $_);
$tmpkey="$tqno-qcucmt";
$tqno =~ s/q//g;
if ($tqno > $hitqno) {
$hitqno = $tqno;
}
$tqidx =~ s/([0-9])//g;
if ($tqidx eq 'qrs') {
# setup qrs and qcucmt for putting
$FORM{'qrs'} = $FORM{$_};
$FORM{'qcucmt'} = $FORM{$tmpkey};
#} elsif ($tqidx eq 'qcucmt') {
## setup qcucmt and qrs for putting
## haven't we already done this?
### Yup, we have. DED 9/21/04
#$FORM{'qcucmt'} = $FORM{$_};
#if ($FORM{'qcucmt'} ne '') {
#$tmpkey =~ s/qcucmt/qrs/g;
#$FORM{'qrs'} = $FORM{$tmpkey};
#} else {
#next;
#}
} else {
$tqidx =~ s/qrs//g;
next;
}
$QUESTION{'id'} = &get_question_id($tsubtest, $tqno);
&get_question_definition($TEST{'id'}, $CLIENT{'clid'}, $QUESTION{'id'});
&put_question_response($tsubtest, $tqno);
}
}
$tqno=$hitqno;
}
sub check_for_custom_exit_file {
my ($passfailflag) = @_;
my $rec;
my $customexitfile=join($pathsep,$questionroot,"$TEST_SESSION{'subtest'}.$SESSION{'clid'}.cx$passfailflag");
if (file_exists($customexitfile)) {
if (open(TMPFILE,"<$customexitfile")) {
my @cstextrecs=<TMPFILE>;
close TMPFILE;
my $customexistmsg="";
foreach $rec (@cstextrecs) {
$customexistmsg=join('',$customexistmsg,$rec);
}
$TEST{'customexitmsg'}="$customexistmsg";
@cstextrecs=();
return "Y";
}
}
return "N";
}
sub send_custom_exit_email {
my ($passfailflag) = @_;
my $rec;
my $customemailfile=join($pathsep,$questionroot,"$TEST_SESSION{'subtest'}.$SESSION{'clid'}.ce$passfailflag");
if (file_exists($customemailfile)) {
if (open(TMPFILE,"<$customemailfile")) {
my @cstemlrecs=<TMPFILE>;
close TMPFILE;
$mmfrom = $CLIENT{'email_from'};
$mmto = $CANDIDATE{'eml'};
$mmsubj = $TEST{'desc'}." Completion Certificate";
my $customemailmsg="";
foreach $rec (@cstemlrecs) {
$rec = &xlatline($rec, '', 0, 1);
$customemailmsg=join('',$customemailmsg,$rec);
}
@cstemlrecs=();
$mmbody = "";
$htmlfile = "$SESSION{'clid'}.$SESSION{'uid'}.$TEST{'id'}.htm";
$mmbody = "MIME-version: 1.0\n" ;
$mmbody .= "Content-type: text/html\n" ;
$mmbody .= "Content-transfer-encoding: base64\n" ;
$mmbody .= "Content-Disposition: attachment; filename=" ;
$mmbody .= "\"${htmlfile}\"\n\n" ; # The second \n is required.
$mmbody .= encode_base64($customemailmsg) ;
# open(ATTACHFILE, "> /tmp/$htmlfile");
# print ATTACHFILE $customemailmsg;
# close(ATTACHFILE);
# `/usr/bin/uuencode /tmp/$htmlfile $htmlfile > /tmp/$htmlfile.uu`;
# open(UUFILE, "/tmp/$htmlfile.uu");
# while (<UUFILE>) {
# $mmbody = join('', $mmbody,$_);
# }
# close(UUFILE);
# unlink("/tmp/$htmlfile");
# unlink("/tmp/$htmlfile.uu");
&send_mail($mmfrom, $mmto, $mmsubj, $mmbody);
}
}
}
sub resend_exit_emails {
my ($clid, $cndid, $testid) = @_;
&get_candidate_profile($clid, $cndid);
$TEST_SESSION{'subtest'} = $testid;
&get_test_sequence_for_reports( $clid, $cndid, $testid);
&get_subtest_profile( $clid, $testid);
my $passfailflag=&summarize_test(2);
my $mtime = (stat($testcomplete.$pathsep.$clid.".".$cndid.".".$testid))[9];
$endtime = &format_date_time("h:nn:ss", "2", "-10000", $mtime);
$enddate = &format_date_time("dd-mmm-yyyy", "2", "-10000", $mtime);
&send_testresults("2", $endtime, $enddate);
&send_custom_exit_email($passfailflag);
}
sub redirect {
my $location = $_[0];
my %vars = %{$_[1]};
my $vars = "";
if (scalar keys %vars != 0) {
foreach (keys %vars) {
$vars .= "&".$_."=".$vars{$_};
}
$vars =~ s/^&/\?/;
}
if ($ENV{'HTTPS'} eq "on") {
$url = "https://";
} else {
$url = "http://";
}
$url .= $ENV{'HTTP_HOST'};
$url .= "/cgi-bin/".$location.".pl$vars";
warn "ReDirect to $url ." if ($HBI_Debug_redirect) ;
print "Location: $url\n\n";
}
# end with True because this is a require file
1