You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
3136 lines
91 KiB
3136 lines
91 KiB
#!/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 Normal_Equal {
|
|
# normal_equal does an equality test of two strings.
|
|
# They are an answer string and a response string.
|
|
# They are compared in a string insensitive manner,
|
|
# and minimizing the impact of white space.
|
|
my ($cans, $crsp) = @_ ;
|
|
my $cans_norm = $cans ; my $crsp_norm = $crsp ;
|
|
# Normalize the answer given and the correct answer.
|
|
# Strip leading and trailing white space.
|
|
# Reduce multiple consecutive white space characters in the middle to a single space.
|
|
$cans_norm =~ s/^\s+// ; $cans_norm =~ s/\s+$// ; $cans_norm =~ s/\s+/ /g ;
|
|
$crsp_norm =~ s/^\s+// ; $crsp_norm =~ s/\s+$// ; $crsp_norm =~ s/\s+/ /g ;
|
|
$cans_norm = lc ($cans_norm) ; $crsp_norm = lc ($crsp_norm) ;
|
|
my $iscorrect = ($cans_norm eq $crsp_norm) ? 1 : 0;
|
|
return $iscorrect ;
|
|
}
|
|
|
|
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 = &Normal_Equal ($ansmask , $crsp) ;
|
|
$byquestion = join('/', $byquestion, "$iscorrect.$ansmask.$crsp");
|
|
} elsif ($cans =~ m/\,/) {
|
|
@ansopts = split(/\,/,$cans);
|
|
$iscorrect = 0;
|
|
foreach $ansopt (@ansopts) {
|
|
if ( &Normal_Equal ($crsp , $ansopt)) {
|
|
$iscorrect = 1;
|
|
}
|
|
}
|
|
#&dbgprint("\t:314:$_:$#ansopts:$crsp\n");
|
|
$byquestion = join('/', $byquestion, "$iscorrect.$cans.$crsp");
|
|
} else {
|
|
$iscorrect = &Normal_Equal ($cans, $crsp) ;
|
|
#&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 ( &Normal_Equal($crsp , $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 = &Normal_Equal($cans, $crsp) ;
|
|
}
|
|
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
|
|
|