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.
 
 
 
 
 
 

2756 lines
74 KiB

#!/usr/bin/perl
#
# $Id: smilib.pl,v 1.51 2006/11/28 21:07:48 psims Exp $
#
# Source File: smilib.pl
require 'sitecfg.pl';
use POSIX;
use Time::HiRes;
use CGI qw/:standard/;
sub get_client_configuration {
$omsg = "not found";
if ($_[0]) {
$trash = join( $pathsep, $dataroot, "config.$_[0]");
$omsg = "";
open( CFGFILE, "<$trash" ) or $omsg="not found";
}
if ($omsg eq 'not found') {
$trash = join( $pathsep, $dataroot, "config.$SESSION{'clid'}");
$omsg = "";
open( CFGFILE, "<$trash" ) or $omsg="not found";
}
if ($omsg eq 'not found') {
$trash = join( $pathsep, $dataroot, "config.std");
open( CFGFILE, "<$trash" ) or return;
}
@cfgentries = <CFGFILE>;
close CFGFILE;
for (0 .. $#cfgentries) {
chop ($cfgentries[$_]);
($entrykey,$entryvalue) = split(/=/, $cfgentries[$_]);
$SYSTEM{$entrykey} = $entryvalue;
}
if (($SESSION{'clid'} ne 'sacc') && ($SESSION{'clid'} ne 'std')) {
$SYSTEM{'languagesupport'} = ($SYSTEM{'ALLOWEDLANGS'} eq '' || $SYSTEM{'ALLOWEDLANGS'} =~ /none/) ? "FALSE" : "TRUE";
} else {
$SYSTEM{'languagesupport'} = "TRUE";
}
}
sub put_client_configuration {
$omsg = "not found";
if ($_[0]) {
$trash = join( $pathsep, $dataroot, "config.$_[0]");
$omsg = "";
open( CFGFILE, "<$trash" ) or $omsg="not found";
}
if ($omsg eq 'not found') {
$trash = join( $pathsep, $dataroot, "config.$SESSION{'clid'}");
$omsg = "";
open( CFGFILE, "<$trash" ) or $omsg="not found";
}
if ($omsg eq 'not found') {
$trash = join( $pathsep, $dataroot, "config.std");
open( CFGFILE, "<$trash" ) or return;
}
@cfgentries = <CFGFILE>;
close CFGFILE;
for (0 .. $#cfgentries) {
chop ($cfgentries[$_]);
($entrykey,$entryvalue) = split(/=/, $cfgentries[$_]);
$key = "C$entrykey";
$key =~ s/ /+/g;
if ($FORM{$key} ne '') {
$cfgentries[$_] = "$entrykey=$FORM{$key}";
} else {
if ( $entrykey eq 'IP_ACCESS_FILTER') {
$cfgentries[$_] = "$entrykey=$FORM{'CIP_ACCESS_FILTER'}";
}
}
}
$omsg = "not found";
if ($_[0]) {
$trash = join( $pathsep, $dataroot, "config.$_[0]");
$omsg = "";
open( CFGFILE, ">$trash" ) or $omsg="not found";
}
if ($omsg eq 'not found') {
$trash = join( $pathsep, $dataroot, "config.$SESSION{'clid'}");
$omsg = "";
open( CFGFILE, ">$trash" ) or $omsg="not found";
}
if ($omsg ne 'not found') {
for (0 .. $#cfgentries) {
print CFGFILE "$cfgentries[$_]\n";
}
close CFGFILE;
}
$chmodok = chmod 0666, $trash;
}
sub createtrace {
my $trash = join( $pathsep, $secroot, "$ENV{'REMOTE_ADDR'}.log");
my $msg = "";
open( TRACEFILE, "<$trash") or $msg = "notfound";
if ($msg eq 'notfound') {
open( TRACEFILE, ">$trash" ) || return 0;
my $starttime= &format_date_time("yyyy-mm-dd hh:nn:ss GMT", "1", "0");
print TRACEFILE "$starttime\n";
close TRACEFILE;
my $chmodok = chmod 0666, $trash;
} else {
close TRACEFILE;
}
&opentrace();
}
sub traceoutput {
if ($SYSTEM{'traceon'} != 1) {
if (&opentrace()) {
&createtrace();
}
}
if ($SYSTEM{'traceon'} == 1) {
print TRACEFILE "$_[0]\n";
};
}
sub opentrace {
my $trash = join( $pathsep, $secroot, "$ENV{'REMOTE_ADDR'}.log");
open( TRACEFILE, ">>$trash" ) || return 0;
$SYSTEM{'traceon'} = 1;
my $starttime= &format_date_time("yyyy-mm-dd hh:nn:ss GMT", "1", "0");
&traceoutput($starttime);
return 1;
}
sub closetrace {
$SYSTEM{'traceon'} = 0;
my $starttime= &format_date_time("yyyy-mm-dd hh:nn:ss GMT", "1", "0");
&traceoutput($starttime);
close TRACEFILE;
}
sub createdebug {
$trash = join( $pathsep, $secroot, "debug.$SESSION{'clid'}.txt");
$msg = "";
open( DBGFILE, "<$trash") or $msg = "notfound";
if ($msg eq 'notfound') {
open( DBGFILE, ">$trash" ) || return 0;
$starttime= &format_date_time("yyyy-mm-dd hh:nn:ss GMT", "1", "0");
&dbgprint("$starttime\n");
close DBGFILE;
$chmodok = chmod 0666, $trash;
} else {
close DBGFILE;
}
&opendebug("debug.txt");
}
sub opendebug {
$trash = join( $pathsep, $secroot, "debug.$SESSION{'clid'}.txt");
open( DBGFILE, ">>$trash" ) || return 0;
$debugon = 1;
return 1;
}
sub dbgprint {
my ($s) = @_;
&opendebug();
print DBGFILE "$SESSION{'tid'}:$SESSION{'uid'}:$s";
&closedebug();
}
sub closedebug {
$debugon = 0;
close DBGFILE;
}
sub showenv {
for (keys %ENV) {
if ($debugon) {
&dbgprint("$_ = $ENV{$_}\n");
} else {
print "<!-- $_ = $ENV{$_} -->\n";
}
}
$reqmeth = $ENV{'REQUEST_METHOD'};
if ($reqmeth =~ /POST/i) {
read (STDIN, $qstr, $ENV{'CONTENT_LENGTH'});
if ($debugon) {
&dbgprint("POSTED = $qstr\n");
} else {
print "<!-- POSTED = $qstr -->\n";
}
}
}
sub show_message_with_close {
print "
<HTML>
<BODY>
<CENTER>
$_[0]<BR>
\&nbsp;<BR>
<FORM>
<INPUT TYPE=SUBMIT VALUE=\"CLOSE\" onClick='window.close()'><BR>
</FORM>
</BODY>
</HTML>
";
}
### DED-03 8/6/2002 Added this function to replace show_message_with_close
### because it would close entire browser window
sub show_message_with_back {
$URL="$PATHS{'cgiroot'}/sadmin.pl?tid=$SESSION{'tid'}&dtl=$_[1]&lang=$FORM{'lang'}";
print "
<HTML>
<BODY>
<CENTER>
$_[0]<BR>
\&nbsp;<BR>\n";
if ($_[1] == 2) {
print "<a href=$URL target=_parent>BACK</a>\n";
} else {
print "<a href=$URL>BACK</a>\n";
}
print "
</BODY>
</HTML>
";
}
sub file_exists {
open (TMPFILE,"<$_[0]") or return 0;
close TMPFILE;
return 1;
}
sub file_exists_with_extension {
@feexts = split(/\;/, $_[1]);
foreach $feext (@feexts) {
$fename = "$_[0].$feext";
if (&file_exists($fename)) {
@feexts = ();
$feext = "";
return $fename;
}
}
@feexts = ();
$feext = "";
$fename = "";
return "";
}
sub app_initialize {
$FORM{servertime} = POSIX::strftime($UI{DATETIME_FMT}, localtime(time));
# parse request parameters into variables
$query = new CGI;
%FORM = $query->Vars;
#foreach $key (keys(%FORM)) {
#if ($FORM{$key} =~ /\-\-$/) {
#chop($FORM{$key});
#chop($FORM{$key});
#}
#}
### DED Rip ALL this out, change UPLOADED_FILES references
### to use "CGI::upload"
#if ($ftype eq 'csv') {
#$content =~ s/\r//g;
#$content =~ s/\n\n/\n/g;
#} else {
#### DED 1/24/06
## Removed for png supt
## but breaks reports
##$content =~ s/(.*)\r\n/$1/;
#$content =~ s/(.*)\r\n/$1/;
#}
# make sure connection is https
$set_https = 0;
if ($FORM{'clid'} ne '') {
&get_client_configuration($FORM{'clid'});
$set_https = 0;
} elsif ($FORM{'tid'} ne '' && &get_session($FORM{'tid'})) {
&get_client_configuration($SESSION{'clid'});
$set_https = 0;
}
if ($set_https) {
if ( ($ENV{'HTTPS'} ne "on") && ( ($SYSTEM{'FORCEHTTPSOVERRIDE'} eq "Yes") || ($SYSTEM{'FORCEHTTPSOVERRIDE'} ne "No" && $SYSTEM{'forcehttps'}) ) ) {
$url = "https://".$ENV{'SERVER_NAME'};
if ($ENV{'SERVER_PORT'} != "80") {
$port = $ENV{'SERVER_PORT'} + 1;
$url .= ":".$port;
}
$url .= $ENV{'REQUEST_URI'};
print "Location: $url\n";
}
}
if ($qstr) {
return 1;
} else {
return 0;
}
}
sub copy_file {
system("cp $_[1] $_[0] -p");
print "<br>File successfully copied...<br>";
return 1;
}
sub make_file {
if ( ! open (TMPFILE, "<$_[1]") ) {
&logger::logerr("Unable to open $_[1] for reading: $!\n");
return 0;
}
@copylines = <TMPFILE>;
close TMPFILE;
if ( ! open (TMPFILE, ">$_[0]") ) {
&logger::logerr("Unable to open $_[0] for writing: $!\n");
return 0;
}
if ($_[2] == 1) {
print TMPFILE "$copylines[0]";
} else {
foreach $copyline (@copylines) {
print TMPFILE "$copyline";
}
}
close TMPFILE;
$chmodok = chmod 0666, $_[0];
return 1;
}
sub get_io_file {
if ( ! open (TMPFILE, "<$_[0]") ) {
&logger::logerr("Unable to open $_[0] for reading: $!\n");
return 0;
}
@copylines = <TMPFILE>;
close TMPFILE;
if ( ! open (TMPFILE, ">$_[1]") ) {
&logger::logerr("Unable to open $_[1] for writing: $!\n");
return 0;
}
foreach $copyline (@copylines) {
print TMPFILE "$copyline";
}
close TMPFILE;
$chmodok = chmod 0666, $_[1];
return 1;
}
############################################################################
#
# Function: cpbin( $fromfile, $tofile, $opts )
#
# Description: Perform a binary copy of one binary file to another.
#
# Usage: cpbin( $fromfile, $tofile, $opts )
#
# $opts is a hashref of options as follows:
#
# $opts->{clobber} : If set to 1, any existing $tofile will be clobbered.
# Otherwise, the copy will fail and return 0.
#
# Returns: 1 if successful, 0 if not, with very little error-checking
# to prevent accidental clobbering.
#
# Author: efl, 11/2001
#
############################################################################
sub cpbin {
my($fromfile, $tofile, $opts) = @_;
my $clobber = $opts->{clobber};
if ( -f $tofile && ! $clobber ) {
&logger::logerr("Unable to open $fromfile for writing: File exists and no clobbering allowed. Set \$opts->{clobber} = 1 to force clobbering.\n");
return 0;
}
if ( ! open (INFILE, "<$fromfile") ) {
&logger::logerr("Unable to open $fromfile for reading: $!\n");
return 0;
}
binmode(INFILE);
@content = <INFILE>;
close INFILE;
if ( ! open (OUTFILE, ">$tofile") ) {
&logger::logerr("Unable to open $tofile for writing: $!\n");
return 0;
}
binmode(OUTFILE);
foreach $content (@content) {
print OUTFILE $content;
}
close OUTFILE;
return 1;
}
sub gentid {
$coreid = time;
$spfmt = join('', "\%s\%0", sprintf("%d", length($idmax)), "d");
$tid = sprintf( $spfmt, $coreid, (int(rand(0) * $idmax)));
return $tid;
}
sub init_session {
if ($FORM{'clid'} eq 'sacc') { $FORM{'clid'} = 'std';}
$SESSION{'tid'} = &gentid;
$SESSION{'clid'}=$FORM{'clid'};
$SESSION{'uid'}=$FORM{'uid'};
$SESSION{'uac'}=$FORM{'uac'};
$SESSION{'useragent'}=$ENV{'HTTP_USER_AGENT'};
$SESSION{'ipaddr'}=$ENV{'REMOTE_ADDR'};
$SESSION{'referer'}=$ENV{'HTTP_REFERER'};
$SESSION{'home'}=$FORM{'home'};
$SESSION{'lang'}=$FORM{'lang'};
$SESSION{'loggedin'}=time;
if ($FORM{'browser'} eq '') {
if ($SESSION{'useragent'} =~ /MSIE/ ) {
$FORM{'browser'} = "MSIE/4";
} else {
$FORM{'browser'} = "NSNV/4";
}
}
($SESSION{'browserapp'}, $SESSION{'browserversion'}) = split(/\//, $FORM{'browser'});
&put_session($SESSION{'tid'}, "y");
}
sub get_session {
my ($session_id, $skip_warning) = @_;
if (! defined $session_id) {
warn "HBI Undefined Session id" ;
}
if ($session_id eq "") {
&show_illegal_access_warning unless ($skip_warning);
warn "HBI Blank Session id" ;
return 0;
}
unless ($session_id =~ m/^\d{13,15}$/ ) {
# only 13, 14, or 15 digits is OK.
warn "HBI Bad Session id $session_id ." ;
}
$trash = join($pathsep, $logroot, "sess.$session_id");
open (SESSFILE, "<$trash");
@sessrecs = <SESSFILE>;
close SESSFILE;
if ($#sessrecs == -1) {
&show_illegal_access_warning unless ($skip_warning);
warn "HBI No Lines in Session file." ;
return 0;
} else {
foreach $sessrec (@sessrecs) {
chop ($sessrec);
($nm,$vlu)=split(/=/,$sessrec);
$SESSION{$nm} = $vlu;
}
unless ($SESSION{'clid'}) {
warn "HBI Unknown Client ID in Session file." ;
}
unless ($SESSION{'uid'}) {
warn "HBI Unknown Candidate ID in Session file." ;
}
if ($SESSION{'clid'} eq 'sacc') { $SESSION{'clid'} = 'std';}
# FIXME: AOL's use of dynamically changing IP addresses on each
# FIXME: successive pageview breaks fails against this scheme.
# DED 2005-11-08 Removed to facilitate round-robin proxies
#$sameuser = ($SESSION{'ipaddr'} eq $ENV{'REMOTE_ADDR'}) ? 1 : 0;
#if ( $SESSION{'ipaddr'} ne $ENV{'REMOTE_ADDR'} ) {
# &logger::logwarn("SESSION{'ipaddr'} ($SESSION{'ipaddr'}) !== ENV{'REMOTE_ADDR'} ($ENV{'REMOTE_ADDR'}) for session ID $session_id");
#}
#$sameuser = ($SESSION{'loggedout'} ne '') ? 0 : $sameuser;
$sameuser = ($SESSION{'loggedout'} ne '') ? 0 : 1;
if ( $SESSION{'loggedout'} ne '' ) {
&logger::logwarn("SESSION{'loggedout'} ($SESSION{'loggedout'}) !== '' for session ID $session_id ... meaning exactly what??");
}
return $sameuser;
}
}
sub close_session {
$SESSION{'loggedout'}=time;
&put_session($SESSION{'tid'});
$tofile = join($pathsep, $logroot, "sess.$_[0]");
$archivefile = join($pathsep, $logroot, "sess.$_[0]");
rename $tofile, $archivefile;
}
sub set_session {
my $temp = $_[2];
&get_session($_[0]);
$SESSION{$_[1]} = $temp;
&put_session($_[0]);
}
sub put_session {
if ($_[0] eq "") {
return 0;
}
$SESSION{'lastaccess'}=time;
$trash = join($pathsep, $logroot, "sess.$_[0]");
open (SESSFILE, ">$trash");
for (keys %SESSION) {
print SESSFILE "$_\=$SESSION{$_}\n";
}
close SESSFILE;
if ($_[1] eq 'y') { $chmodok = chmod 0666, $trash;}
}
sub show_illegal_access_warning {
my ($user) = @_;
&send_illegal_attempt;
print "<HTML>\n";
print "<BODY>\n";
print "\&nbsp;<BR>\n";
if ($user eq "user") {
print "Attention User:<br>\n";
print "Either your IP address has changed or the session tracking mechanisms have encountered an error. \n";
print "Please logoff and contact your administrator for assistance.<BR>\n";
} else {
print "Attention Site Administrators:<br>\n";
print "You have either requested a service that is unavailable at this time, \n";
print "or else the session tracking mechanisms have encountered an error. \n";
print "Please try another selection, or logoff and logon again to reset session tracking.<BR>\n";
}
print "\&nbsp;<BR>\n";
print "\&nbsp;<BR>\n";
# print "Attention Hackers:<br>You have attempted to gain access to this secure site \n";
# print "by bypassing the site security.<BR>\n";
# print "\&nbsp;<BR>\n";
# print "The contents of this site are protected by United States and International copyright laws.<BR>\n";
# print "The information on this site is proprietary and protected by United States and International information privacy laws.<BR>\n";
# print "\&nbsp;<BR>\n";
# print "This invalid attempt has been logged, the site administrator notified, and your access route traced.<BR>";
# print "Any further unauthorized access attempts from $ENV{'REMOTE_ADDR'} will result ";
# print "in further investigation and possible prosecution.<BR>\n";
print "</BODY>\n";
print "</HTML>\n";
}
sub check_admin_profiles {
my ($cndid) = @_;
@aprofs = &get_data("admin.dat");
foreach $aprof (@aprofs) {
($aid, $trash) = split(/&/, $aprof);
if ($aid eq $cndid) {
return 1;
}
}
return 0;
}
sub checkinprogress {
my ($clid, $uid) = @_;
# FIXME: This code, which I commented out, is a nagging mystery.
# FIXME: Why was it here? Can't see how it worked? -efl, 1/2002
# $tmpfile = join( $pathsep, $testroot, "inprog", "$uid.dat");
# open (TMPFILE, "<$tmpfile") || return 0;
# @pairs = <TMPFILE>;
# close TMPFILE;
$testdir = join( $pathsep, $testroot, "inprog");
if ( ! opendir(DIR, $testdir) ) {
&logger::logerr("Unable to opendir $testdir: $!");
return 0;
}
@filenames = readdir(DIR);
closedir(DIR);
my @inprogtests = ();
foreach my $srcfile ( @filenames ) {
if ( $srcfile =~ /^$clid\.$uid\.(.*)$/ ) {
my $testid = $1;
#
# Now check to see if we are within the availability window
#
if ( &within_availability_window($clid, $testid, time) ) {
# FIXME: Don't actually note the inprogress test file because this code
# FIXME: never worked before and was compensated for elsewhere. If it
# FIXME: ain't broke, don't fix it. If you uncomment the line below,
# FIXME: then this code works, but test resumption does not. -efl, 1/2002
# push( @inprogtests, $testid );
}
}
}
if ( scalar(@inprogtests) > 1 ) {
&logger::logerr("There are ".scalar(@inprogtests)." tests in progress and available for uid $uid, clid $clid: [".join(', ', @inprogtests)."]. It was previously assumed this would not happen. No interface yet to choose which one to resume.");
}
$FORM{'uac'} = "";
return scalar(@inprogtests);
}
# returns 1 if current time is within availability window, 0 if not
#
# $time is in secs since 1970...
sub within_availability_window {
my ($clid, $testid, $time) = @_;
my ($rc, $msg, $start, $end) = get_availability_window($clid, $testid);
if ( ! $rc ) {
&logger::logerr("Unable to retrieve availability window for clid '$clid', testid '$testid': $msg");
return 0;
}
if ( $time > $start && $time < $end ) {
return 1;
} else {
return 0;
}
}
sub get_availability_window( $ $ ) {
my ($clid, $testid) = @_;
my ($rc, $msg, $start, $end) = (0, "N/A", 0, 0);
### DED 11/19/02 Have to restore original test profile when done
my $holdtestid = $TEST{'id'};
if ( ! &get_test_profile($clid, $testid) ) {
&logger::logerr("Failed to get profile for clid '$clid', testid '$testid'");
($rc, $msg, $start, $end) = (0, "Failed to retrieve test profile", 0,0);
&get_test_profile($clid, $holdtestid);
return ($rc, $msg, $start, $end);
}
$start = datetime_to_secssince1970( $TEST{availon} );
if ( ! defined($start) ) {
($rc, $msg, $start, $end) = (0, "Unable to parse availability start: [$TEST{availon}]", 0,0);
&logger::logerr("Unable to parse \$TEST{availon} = $TEST{availon}");
&get_test_profile($clid, $holdtestid);
return ($rc, $msg, $start, $end);
}
$end = datetime_to_secssince1970( $TEST{availthru} );
if ( ! defined($end) ) {
($rc, $msg, $start, $end) = (0, "Unable to parse availability end: [$TEST{availthru}]", 0,0);
&logger::logerr("Unable to parse \$TEST{availthru} = $TEST{availthru}");
&get_test_profile($clid, $holdtestid);
return ($rc, $msg, $start, $end);
}
&get_test_profile($clid, $holdtestid);
return (1, $msg, $start, $end);
}
sub checkalreadyloggedin {
$luid = "$_[0].$_[1]";
open (LOGINFILE, "<$logroot/ulog.dat");
@loginrecs = <LOGINFILE>;
close LOGINFILE;
foreach $loginrec (@loginrecs) {
chop $loginrec;
($lguid, $lgupid, $lgutm) = split(/&/, $loginrec);
if ($lguid eq $luid) {
return 1;
}
}
open (LOGINFILE, ">>$logroot/ulog.dat");
print LOGINFILE "$_[0]\&$_[1]\&$$\n";
close LOGINFILE;
return 0;
}
## v support for wildcard ids
sub IsTaclID {
my ($clid,$taclid,$pwd,$testid) = @_;
#
# see if there are any test access ids for this client
#
my @taclrecs=&get_data("tacl.$clid");
unless ($#taclrecs > 0) { return 0;}
#
# now build a list of available tests for the login id given
#
my @flds;
my $lctaclid=lc($taclid);
my $uctaclid=uc($taclid);
my $rec="($taclid|$uctaclid|$lctaclid)\&(.*)\&$pwd\&";
my @trecs=grep( /$rec/, @taclrecs);
my $rec=shift @taclrecs;
@taclrecs=();
unless ($#trecs != -1) { return 0};
#
# found some matches, now confirm the password to verifry the grep
#
my $taclauthtests="";
my $tsep="";
foreach $tacl (@trecs) {
chop ($tacl);
@flds=split(/&/,$tacl);
if ($flds[2] eq $pwd) {
$taclauthtests=join ('::',$taclauthtests,"$tacl");
}
}
@trecs=();
unless ($taclauthtests ne '') { return 0};
$taclauthtests = substr($taclauthtests,2);
#
# There is a list, so verify access for this id
#
### DED 3/5/04 Added for auto-login support
if ($pwd eq "_____") {
$rec = "$taclid&$testid&$pwd";
@trecs=grep( /$rec/, $taclauthtests);
unless ($#trecs != -1) { return 0};
$SESSION{'taclid'}=get_anon_seqno($clid, $testid);
} else {
$SESSION{'taclid'}="$taclid.$pwd";
}
$SESSION{'taclauthtests'}=$taclauthtests;
$SESSION{'uac'} = "cnd";
return 1;
}
## ^ support for wildcard ids
sub verifyaccess {
$FORM{'uac'} = "";
## v support for wildcard ids
if (&IsTaclID($FORM{'clid'},$FORM{'uid'},$FORM{'pwd'},$FORM{'testid'})) {
return 1;
}
## ^ support for wildcard ids
if ($FORM{'tadm'} ne '' || $FORM{'sadm'} ne '') {
$tmpfile = "admin.dat";
($oldpass,$newpass,$confirmpass) = split(/\//, $FORM{'pwd'});
} else {
$oldpass = $FORM{'pwd'};
$newpass = "";
if ($FORM{'cnd'} ne '') {
$tmpfile = "cnd.$FORM{'clid'}";
} else {
# self assessment request
if ($FORM{'sar'} ne '') {
$tmpfile = "sar.$FORM{'clid'}";
} else {$uacerror = 1;}
}
}
unless ($uacerror) {
@pairs = &get_data($tmpfile);
foreach $pair (@pairs) {
chop ($pair);
($id, $pw, $pv, $clid) = split(/&/, $pair);
if ($id eq $FORM{'uid'}) {
if ($pw eq $oldpass) {
if ($FORM{'tadm'} ne '' || $FORM{'sadm'} ne '') {
$FORM{'uac'} = $pv;
$FORM{'clid'} = ($clid eq 'sacc') ? "std" : $clid;
if ($newpass ne '') {
if ($newpass eq $confirmpass) {
if (&change_password($id,$newpass,$pv,$clid)) {
$SYSTEM{'message'} = "Your password has been changed."
} else {
$SYSTEM{'message'} = "Your password could not be changed."
}
} else {
$SYSTEM{'pwchange'} = "Your password was not changed. The new password and confirming password did not match."
}
} else {
$SYSTEM{'pwchange'} = ""
}
} else {
@flds = split(/&/, $pair);
#if ($FORM{'sas'} ne '') {
if ($flds[17] eq 'Y') {
$FORM{'uac'} = "sas";
$FORM{'sas'} = "xxx";
} else {
$FORM{'uac'} = "cnd";
}
$FORM{'clid'} = $FORM{'clid'};
}
if ($ipfilter ne '') {
if ($FORM{'uac'} ne 'gadmin') {
if (&ipfilteredaccess($ipfilter,$ENV{'REMOTE_ADDR'})) {
return 1;
} else {
return 0;
}
} else {
return 1;
}
} else {
$SESSION{'clid'} = $FORM{'clid'};
&get_client_configuration();
if ($SYSTEM{'IP_ACCESS_FILTER'} ne '') {
$SYSTEM{'message'} = "System is Locked Down";
if (($FORM{'uac'} ne 'gadmin') && ($FORM{'uac'} ne 'admin') && ($FORM{'uac'} ne 'madmin')) {
if (&ipfilteredaccess($SYSTEM{'IP_ACCESS_FILTER'},$ENV{'REMOTE_ADDR'})) {
return 1;
} else {
return 0;
}
} else {
return 1;
}
} else {
return 1;
}
}
}
}
}
if ($FORM{'cnd'} ne '') {
$FORM{'tadm'} = "xxx";
$FORM{'cnd'} = "";
if (&verifyaccess) {
if ($ipfilter ne '') {
if ($FORM{'uac'} ne 'gadmin') {
if (&ipfilteredaccess($ipfilter,$ENV{'REMOTE_ADDR'})) {
return 1;
} else {
if (($SYSTEM{'IP_ACCESS_FILTER'} ne '') && ($FORM{'uac'} ne 'gadmin')) {
if (&ipfilteredaccess($SYSTEM{'IP_ACCESS_FILTER'},$ENV{'REMOTE_ADDR'})) {
return 1;
} else {
return 0;
}
} else {
return 1;
}
}
} else {
return 1;
}
} else {
return 1;
}
} else {
return 0;
}
}
}
return 0;
}
sub change_password {
@rs = &get_data("admin.dat");
$rskp = shift @rs;
foreach $rs (@rs) {
chop ($rs);
($xxid, $xxpw, $xxpv, $xxclid) = split(/&/, $rs);
if ($xxid eq $_[0]) {
$rs = join('&', $_[0], $_[1], $_[2], $_[3]);
}
push @newrs, $rs;
}
@rs = sort @newrs;
@newrs = ();
$tmpfile = join($pathsep, $dataroot, "admin.dat");
open (TMPFILE, ">$tmpfile") or return 0;
print TMPFILE "$rskp";
foreach $rs (@rs) {
print TMPFILE "$rs\n";
}
close TMPFILE;
return 1;
}
sub eval_logical_html {
my ($exaction, $value, $exval) = @_;
$exludeflag = 0;
@exvals = split(/\,/, $exval);
foreach $exval (@exvals) {
if ($exval eq 'NULL') {
$exval = "";
}
if ($exaction eq 'INCLUDE') {
$exludeflag = ($value eq $exval) ? 0 : 1;
} else {
$exludeflag = ($value eq $exval) ? 1 : 0;
}
last if($value eq $exval);
}
return $exludeflag;
}
sub xlatline {
my ($xltline, $fh, $escapem, $parse_nop) = @_; # print translation to filehandle $fh
$fh = (defined($fh) ? $fh : *STDOUT);
if ($#sifnests == -1) {
$sifnests[0] = 0;
$sifncnt = 0;
$sifnestlevel = 0;
}
if ($xltline =~ /(<%=)NOP_(\S+.*?%>)/i && $parse_nop) {
$xltline =~ s/(<%=)NOP_(\S+.*?%>)/$1$2/g;
}
my $nopopuptag ;
if ($xltline =~ /<%=SYSTEM\.STARTIF.(.*?)%>/i ) {
($trash, $exstatement) = split(/\?/, $xltline);
($exvar, $exval, $exaction, $trash) = split(/ /, $exstatement);
($exarray, $exkey) = split(/\./, $exvar);
if ($exarray eq 'FORM') {
$excludeon = &eval_logical_html($exaction,$FORM{$exkey}, $exval);
} elsif ($exarray eq 'CLIENT') {
$excludeon = &eval_logical_html($exaction,$CLIENT{$exkey}, $exval);
} elsif ($exarray eq 'GROUP') {
$excludeon = &eval_logical_html($exaction,$GROUP{$exkey}, $exval);
} elsif ($exarray eq 'TEST') {
$excludeon = &eval_logical_html($exaction,$TEST{$exkey}, $exval);
} elsif ($exarray eq 'SUBTEST') {
$excludeon = &eval_logical_html($exaction,$SUBTEST{$exkey}, $exval);
} elsif ($exarray eq 'QUESTION') {
$excludeon = &eval_logical_html($exaction,$QUESTION{$exkey}, $exval);
} elsif ($exarray eq 'GRADEBOOK') {
$excludeon = &eval_logical_html($exaction,$GRADEBOOK{$exkey}, $exval);
} elsif ($exarray eq 'CANDIDATE') {
$excludeon = &eval_logical_html($exaction,$CANDIDATE{$exkey}, $exval);
} elsif ($exarray eq 'SYSTEM') {
$excludeon = &eval_logical_html($exaction,$SYSTEM{$exkey}, $exval);
} elsif ($exarray eq 'UI') {
$excludeon = &eval_logical_html($exaction,$UI{$exkey}, $exval);
} elsif ($exarray eq 'SUBJAREA') {
$excludeon = &eval_logical_html($exaction,$SUBJAREA{$exkey}, $exval);
} elsif ($exarray eq 'SESSION') {
$excludeon = &eval_logical_html($exaction,$SESSION{$exkey}, $exval);
}
if ($sifnests[$sifcnt]) {
$sifncnt++;
} else {
$sifncnt++;
$sifnests[$sifncnt] = $excludeon;
for (1 .. $sifncnt) {
$sifnestlevel = $_;
$excludeon = $sifnests[$_];
last if ($excludeon);
}
}
return "";
} elsif ($xltline =~ /<%=SYSTEM\.ELSE%>/i ) {
if ($sifnestlevel == $sifncnt) {
$excludeon = ($excludeon) ? 0 : 1;
}
return "";
} elsif ($xltline =~ /<%=SYSTEM\.ENDIF%>/i ) {
$excludeon = 0;
$sifnests[$sifncnt] = 0;
$sifncnt--;
$sifnestlevel = 0;
for (1 .. $sifncnt) {
$sifnestlevel = $_;
$excludeon = $sifnests[$_];
last if ($excludeon);
}
return "";
} else {
if ($excludeon) { return "";}
}
if ($xltline =~ /<%=(.*?)%>/ ) {
if ($xltline =~ /<%=PATHS\.(.*?)%>/i ) {
for (keys %PATHS) {
$repl = $PATHS{$_};
$srch1 = join('', "<%=PATHS.", $_, "%>");
$xltline =~ s/$srch1/$repl/g;
}
}
if ($xltline =~ /<%=SITE.REPORTS%>/) {
&get_site_reports_list($fh);
}
if ($xltline =~ /<%=SYSTEM\.(.*?)%>/i ) {
if ($xltline =~ /<%=SYSTEM\.INCLUDEJS (.*?)%>/i ) {
@incsegs = split(/ /, $xltline);
$incjsfile = $incsegs[1];
@incsegs = ();
unless ($incjsfile eq '') {
$incjsfile = join($pathsep, $cfgroot, "js", $incjsfile);
open (TMPJSFILE, "<$incjsfile");
@tmpjslines = <TMPJSFILE>;
close TMPJSFILE;
foreach $tmpjsline (@tmpjslines) {
$tmpjsline = &xlatline($tmpjsline, $fh);
}
@tmpjslines = ();
}
return "";
} elsif ($xltline =~ /<%=SYSTEM\.date%>/i ) {
$repl = `date "+%b %d, %Y"`;
$srch1 = "<%=SYSTEM.date%>";
$xltline =~ s/$srch1/$repl/g;
} else {
for (keys %SYSTEM) {
$repl = $SYSTEM{$_};
$srch1 = join('', "<%=SYSTEM.", $_, "%>");
$xltline =~ s/$srch1/$repl/g;
}
}
}
if ($xltline =~ /<%=SESSION\.(.*?)%>/i ) {
for (keys %SESSION) {
$repl = $SESSION{$_};
$srch1 = join('', "<%=SESSION.", $_, "%>");
$xltline =~ s/$srch1/$repl/g;
}
}
if ($xltline =~ /<%=FORM\.servertime%>/i ) {
$repl = POSIX::strftime($UI{DATETIME_FMT}, localtime(time));
$srch1 = join('', "<%=FORM.servertime%>");
$xltline =~ s/$srch1/$repl/g;
} elsif ($xltline =~ /<%=FORM\.(.*?)%>/i ) {
for (keys %FORM) {
$repl = $FORM{$_};
$srch1 = join('', "<%=FORM.", $_, "%>");
$xltline =~ s/$srch1/$repl/g;
}
}
if ($xltline =~ /<%=TEST_SESSION\.(.*?)%>/i ) {
for (keys %TEST_SESSION) {
$repl = $TEST_SESSION{$_};
$srch1 = join('', "<%=TEST_SESSION.", $_, "%>");
$xltline =~ s/$srch1/$repl/g;
}
}
if ($xltline =~ /<%=SUBTEST\.(.*?)%>/i ) {
for (keys %SUBTEST) {
$repl = $SUBTEST{$_};
$srch1 = join('', "<%=SUBTEST.", $_, "%>");
$xltline =~ s/$srch1/$repl/g;
}
}
if ($xltline =~ /<%=GROUP\.(.*?)%>/i ) {
for (keys %GROUP) {
$repl = $GROUP{$_};
$srch1 = join('', "<%=GROUP.", $_, "%>");
$xltline =~ s/$srch1/$repl/g;
}
}
if ($xltline =~ /<%=SUBJAREA\.(.*?)%>/i ) {
for (keys %SUBJAREA) {
$repl = $SUBJAREA{$_};
$srch1 = join('', "<%=SUBJAREA.", $_, "%>");
$xltline =~ s/$srch1/$repl/g;
}
}
if ($xltline =~ /<%=PHRASE\.(.+?)%>/i) {
while ( $xltline =~ m/<%=PHRASE\.(.+?)%>/ix) {
my $id = $1;
$srch1 = join("", "<%=PHRASE.", $id, "%>");
$repl = GetLanguageElement($SESSION{lang}, $id);
$xltline =~ s/$srch1/$repl/g;
}
}
if ($xltline =~ /<%=GRADEBOOK\.(.*?)%>/i ) {
for (keys %GRADEBOOK) {
$repl = $GRADEBOOK{$_};
$srch1 = join('', "<%=GRADEBOOK.", $_, "%>");
$xltline =~ s/$srch1/$repl/g;
}
}
if ($xltline =~ /<%=CLIENTS\.Options%>/i ) {
&print_client_options($fh);
return "";
}
if ($xltline =~ /<%=CLIENTS\.List%>/) {
$client_list = &print_client_list($fh);
$xltline =~ s/<%=CLIENTS.List%>/$client_list/g;
}
if ($xltline =~ /<%=CLIENT\.(.*?)%>/i ) {
if ( $xltline =~ /<%=CLIENT\.REPORTS%>/i) {
&get_client_reports_list($fh, $SESSION{'clid'}, $SESSION{'uid'});
return "";
} elsif ( $xltline =~ /<%=CLIENT.TESTS%>/i) {
&print_noncfa_test_options($CLIENT{'clid'}, $fh);
return "";
} elsif ( $xltline =~ /<%=CLIENT.userlist%>/i) {
&print_client_cnd_options($CLIENT{'clid'}, $fh);
return "";
} elsif ( $xltline =~ /<%=CLIENT.adminids%>/i) {
&print_client_adminids($CLIENT{'clid'}, $fh);
return "";
} elsif ( $xltline =~ /<%=CLIENT.forms%>/i) {
&print_client_test_forms($CLIENT{'clid'}, $fh);
return "";
} elsif ( $xltline =~ /<%=CLIENT.grpowners%>/i) {
&print_group_owners($CLIENT{'clid'}, $fh);
return "";
} elsif ( $xltline =~ /<%=CLIENT.grpowners_ownedby%>/i) {
&print_group_owners($CLIENT{'clid'}, $fh, 1);
return "";
} elsif ( $xltline =~ /<%=CLIENT.registrars_ownedby%>/i) {
&print_registrars($CLIENT{'clid'}, $fh, 1);
return "";
} elsif ( $xltline =~ /<%=CLIENT.groups%>/i) {
&print_client_groups($CLIENT{'clid'}, $fh);
return "";
# v sac modification to standardize test sequence inputs
} elsif ( $xltline =~ /<%=CLIENT.cfas%>/i) {
$repl = &print_client_seqtst_list($CLIENT{'clid'},"cfa",$TEST{'dscl'},$fh);
$srch = join('', "<%=CLIENT.", "cfas", "%>");
$xltline =~ s/$srch/$repl/g;
} elsif ( $xltline =~ /<%=CLIENT.profbs%>/i) {
$repl = &print_client_seqtst_list($CLIENT{'clid'},"profb",$TEST{'profb'},$fh);
$srch = join('', "<%=CLIENT.", "profbs", "%>");
$xltline =~ s/$srch/$repl/g;
} elsif ( $xltline =~ /<%=CLIENT.profas%>/i) {
$repl = &print_client_seqtst_list($CLIENT{'clid'},"profa",$TEST{'profa'},$fh);
$srch = join('', "<%=CLIENT.", "profas", "%>");
$xltline =~ s/$srch/$repl/g;
} elsif ( $xltline =~ /<%=CLIENT.srvys%>/i) {
$repl = &print_client_seqtst_list($CLIENT{'clid'},"srvy",$TEST{'srvy'},$fh);
$srch = join('', "<%=CLIENT.", "srvys", "%>");
$xltline =~ s/$srch/$repl/g;
# ^ sac modification to standardize test sequence inputs
} elsif ( $xltline =~ /<%=CLIENT.userlanguageselect%>/i) {
&print_user_language_select($CLIENT{'clid'});
return "";
} elsif ( $xltline =~ /<%=CLIENT.userlanguageselectdrop%>/i) {
&print_user_language_select($CLIENT{'clid'},1);
return "";
} elsif ( $xltline =~ /<%=CLIENT.forsaletable%>/i) {
&print_client_forsale_table($CLIENT{'clid'}, 0);
return "";
} elsif ( $xltline =~ /<%=CLIENT.ordertable%>/i) {
&print_client_forsale_table($CLIENT{'clid'}, 1);
return "";
} elsif ( $xltline =~ /<%=CLIENT.clcnd1input%>/i) {
&print_clcnd_input($CLIENT{'clid'}, 1, 0, 1);
return "";
} elsif ( $xltline =~ /<%=CLIENT.clcnd2input%>/i) {
&print_clcnd_input($CLIENT{'clid'}, 2, 0, 1);
return "";
} elsif ( $xltline =~ /<%=CLIENT.clcnd3input%>/i) {
&print_clcnd_input($CLIENT{'clid'}, 3, 0, 1);
return "";
} elsif ( $xltline =~ /<%=CLIENT.clcnd4input%>/i) {
&print_clcnd_input($CLIENT{'clid'}, 4, 0, 1);
return "";
} elsif ( $xltline =~ /<%=CLIENT.clcnd1inputf%>/i) {
&print_clcnd_input($CLIENT{'clid'}, 1, "f", 1);
return "";
} elsif ( $xltline =~ /<%=CLIENT.clcnd2inputf%>/i) {
&print_clcnd_input($CLIENT{'clid'}, 2, "f", 1);
return "";
} elsif ( $xltline =~ /<%=CLIENT.clcnd3inputf%>/i) {
&print_clcnd_input($CLIENT{'clid'}, 3, "f", 1);
return "";
} elsif ( $xltline =~ /<%=CLIENT.clcnd4inputf%>/i) {
&print_clcnd_input($CLIENT{'clid'}, 4, "f", 1);
return "";
} else {
for (keys %CLIENT) {
$repl = $CLIENT{$_};
$srch = join('', "<%=CLIENT.", $_, "%>");
$xltline =~ s/$srch/$repl/g;
}
}
}
if ($line =~ /<%=MADMIN.CLIENTS%>/) {
&get_madmin_client_list($SESSION{'mclid'});
}
if ($xltline =~ /<%=INSTANCE\.desc%>/i ) {
$fh = (defined($fh) ? $fh : *STDOUT);
my $repl = &get_a_key("tests.".$SESSION{'clid'}, $TEST{'instanceof'}, "desc");
my $srch = "<%=INSTANCE.desc%>";
$xltline =~ s/$srch/$repl/g;
}
if ($xltline =~ /<%=TESTS\.Options%>/i ) {
&print_std_test_options($SESSION{'clid'}, $fh);
return "";
}
if ($xltline =~ /<%=TESTS\.inherit%>/i ) {
&print_filtered_test_options("std", $CLIENT{'clid'}, $fh);
return "";
}
if ($xltline =~ /<%=TEST\.(.*?)%>/i ) {
for (keys %TEST) {
$repl = $TEST{$_};
$srch = join('', "<%=TEST.", $_, "%>");
$xltline =~ s/$srch/$repl/g;
}
}
if ($xltline =~ /<%=QUESTION\.(.*?)%>/i ) {
for (keys %QUESTION) {
$repl = $QUESTION{$_};
$repl = escape_special_chars( $repl ) if ( $escapem == 1 );
$srch = join('', "<%=QUESTION.", $_, "%>");
$xltline =~ s/$srch/$repl/g;
}
}
if ($xltline =~ /(<%=)ESCAPED_(\S+\..*?%>)/i ) {
#
# I needed a way to indicate from within a template that a value
# needs to be escaped for use within an HTML tag. Thus,
# you may put "ESCAPED_" in front of any template tag
# and it gets removed here, but turns on the escape flag
# for a recursive call to xlatline() and escape_special_chars().
#
# Initially this is only being implemented for %QUESTION,
# but is structured to allow calls to escape_special_chars()
# for other template tag types (see example above). -efl, 2/2002
#
$xltline =~ s/(<%=)ESCAPED_(\S+\..*?%>)/$1$2/g;
return &xlatline($xltline, $fh, 1);
}
if ($xltline =~ /<%=CANDIDATES\.Options%>/i ) {
&print_client_cnd_options($SESSION{'clid'}, $fh);
return "";
}
if ($xltline =~ /<%=CANDIDATE\.(.*?)%>/i ) {
# for (keys %CANDIDATE) # This is the original code. It is a loop. HBI
for (keys %CANDIDATE) {
$srch1 = "<%=CANDIDATE.authtestsoptions%>";
if ($xltline =~ m/$srch1/ ) {
if ($CANDIDATE{'inproglist'} eq '') {
@authtests = split(/\;/, $CANDIDATE{'authlist'});
my $repl = "";
foreach $authtest (@authtests) {
if ($FORM{'testid'} eq "" || $FORM{'testid'} eq "$authtest") {
&get_test_profile($SESSION{'clid'}, $authtest);
#print $fh "<OPTION value=\"$TEST{'pwdtag'}$TEST{'id'}\">$TEST{'desc'}\n";
$repl .= "<OPTION value=\"$TEST{'pwdtag'}$TEST{'popuptag'}$TEST{'id'}\">$TEST{'desc'}\n";
}
}
#return "";
$xltline =~ s/$srch1/$repl/eg;
} else {
@authtests = split(/\;/, $CANDIDATE{'inproglist'});
my $repl = "";
foreach $authtest (@authtests) {
&get_test_profile($SESSION{'clid'}, $authtest);
#print "<OPTION value=\"$TEST{'pwdtag'}$TEST{'id'}\">$TEST{'desc'}\n";
$repl .= "<OPTION value=\"$TEST{'pwdtag'}$TEST{'popuptag'}$TEST{'id'}\">$TEST{'desc'}\n";
}
#return "";
$xltline =~ s/$srch1/$repl/eg;
}
}
$srch1 = "<%=CANDIDATE.authtestslist%>";
if ($xltline =~ m/$srch1/ ) {
$repl = $CANDIDATE{'authlist'};
$replinprog = "";
$replinprog = $CANDIDATE{'inproglist'};
if ($replinprog ne "") {
$replinprog=join('', $replinprog, '*');
if ($repl eq "") {
$repl=$replinprog;
} else {
$repl = join(';', $repl, $replinprog);
}
}
$xltline =~ s/$srch1/$repl/eg;
}
$srch1 = "<%=CANDIDATE.oldtestsoptions%>";
if ($xltline =~ m/$srch1/ ) {
@authtests = split(/\;/, $CANDIDATE{'completedlist'});
my $repl = "";
foreach $authtest (@authtests) {
&get_test_profile($SESSION{'clid'}, $authtest);
$repl .= "<OPTION value=\"$TEST{'emlcndrvwopt'}$TEST{'id'}\">$TEST{'desc'}\n";
}
$xltline =~ s/$srch1/$repl/g;
}
$srch1 = "<%=CANDIDATE.oldtestslist%>";
if ($xltline =~ m/$srch1/ ) {
$repl = $CANDIDATE{'completedlist'};
$xltline =~ s/$srch1/$repl/g;
}
$srch1 = "<%=CANDIDATE.groups%>";
if ($xltline =~ m/$srch1/ ) {
&print_owned_groups($CLIENT{'clid'}, $CANDIDATE{'cndid'}, $fh);
} else {
$repl = $CANDIDATE{$_};
$srch1 = join('', "<%=CANDIDATE.", $_, "%>");
$xltline =~ s/$srch1/$repl/g;
}
# v sac support for self-registration
$srch1 = "<%=CANDIDATE.selfregistertests%>";
if ($xltline =~ m/$srch1/ ) {
if ($CANDIDATE{'inproglist'} ne '') {
@authtests = split(/\;/, $CANDIDATE{'inproglist'});
foreach $authtest (@authtests) {
&get_test_profile($SESSION{'clid'}, $authtest);
print "<OPTION value=\"$TEST{'pwdtag'}$TEST{'popuptag'}$TEST{'id'}\">$TEST{'desc'}";
}
return "";
} else {
$repl=&get_selfreg_test_list($SESSION{'clid'}, $CANDIDATE{'completedlist'});
$xltline =~ s/$srch1/$repl/g;
$xltline =~ s/\n/<\/option>\n/g;
$xltline =~ s/\n<\/option>\n/\n/g;
}
}
}
# ^ sac support for self-registration
}
$srch1 = "<%=DATE%>";
if ($xltline =~ m/$srch1/ ) {
$repl = &format_date_time("dd-mmm-yyyy", 1, "0");
$xltline =~ s/$srch1/$repl/g;
}
if (!($xltline =~ /(<%=)NOP_(\S+.*?%>)/i)) {
$xltline =~ s/<%=(.*?)%>//g;
}
print $fh "$xltline";
} else {
print $fh "$xltline";
}
return $xltline;
}
sub get_template {
my ($template_base) = @_;
# warn "Template $template_base Used." ; # HBI Trace template usage.
# v sac check for custom template
if ($SESSION{'clid'} ne '') {
$tmpfile = join($pathsep, $resptmplt, "$SESSION{'clid'}","$template_base.htt");
} elsif ($FORM{'clid'} ne '') {
$tmpfile = join($pathsep, $resptmplt, "$FORM{'clid'}","$template_base.htt");
} else {
$tmpfile = join($pathsep, $resptmplt, "$CLIENT{'clid'}","$template_base.htt");
}
# ^ sac check for custom template
unless (&file_exists($tmpfile)) {
$tmpfile = join($pathsep, $resptmplt, "$template_base.htt");
}
# &logger::logdbg("Reading template $template_base.htt");
my @locallines;
# FIXME: This should probably just be done with get_data(). -efl
if ( open (TMPFILE, "<$tmpfile") ) {
@locallines = <TMPFILE>;
close TMPFILE;
} else {
&logger::logerr("Unable to open $tmpfile for reading: $!");
}
return @locallines;
}
############################################################################
#
# Function: generate_from_template($template_base, $targetfile)
#
# Description: Read and parse template with name $template_base.htt
# and output result to $targetfile.
#
# Returns: 1 if successful, 0 if not, with very little error-checking
# to prevent accidental clobbering.
#
# Author: efl, 11/2001
#
############################################################################
sub generate_from_template( $ $ ) {
my ($template_base, $targetfile) = @_;
if ( ! $template_base ) {
&logger::logerr("Unexpectedly undefined template basename; aborting template generation process.");
return 0;
}
if ( ! $targetfile ) {
&logger::logerr("Unexpectedly undefined template target filename; aborting template generation process.");
return 0;
}
if ( ! open (OUTFILE, ">$targetfile") ) {
&logger::logerr("Unable to open template target file '$targetfile': $!");
return 0;
}
@lines = &get_template($template_base);
foreach $line (@lines) {
$line = &xlatline($line, *OUTFILE);
}
close OUTFILE;
return 1;
}
sub show_template {
my ($base, $fh) = @_;
$fh = (defined($fh) ? $fh : *STDOUT);
if (defined($SESSION{'lang'})) {
&LoadLanguage($SESSION{'lang'});
} elsif (defined($FORM{'lang'})) {
&LoadLanguage($FORM{'lang'});
}
@lines = &get_template($base);
foreach $line (@lines) {
$line = &xlatline($line, $fh);
}
}
sub show_admin_request {
my ($key) = @_;
&get_template($key);
@lines = &get_template($key);
foreach $line (@lines) {
$line = &xlatline($line);
}
}
sub get_site_reports_list {
my ($fh) = @_;
$fh = (defined($fh) ? $fh : *STDOUT);
@rrecs = &get_data("sitereports.dat");
$nrecs = $#rrecs;
for $i (1 .. $nrecs) {
@flds = split(/&/, $rrecs[$i++]);
print $fh "<OPTION value=\"$flds[0]\">$flds[1]\n";
}
}
sub get_client_reports_list {
my ($fh, $cndid, $uid) = @_;
$fh = (defined($fh) ? $fh : *STDOUT);
my $isaregistrar = &get_a_key("cnd.$cndid", $uid, "registrar");
@rrecs = &get_data("reports.$SESSION{'clid'}");
$nrecs = $#rrecs;
for $i (1 .. $nrecs) {
@flds = split(/&/, $rrecs[$i++]);
if ($isaregistrar eq 'Y') {
if ($flds[0] ne "ENV" && $flds[0] ne "GROUPS") {
print $fh "<OPTION value=\"$flds[0]\">$flds[1]\n";
}
} else {
print $fh "<OPTION value=\"$flds[0]\">$flds[1]\n";
}
}
}
my %data_get_data = () ;
sub get_data {
my ($file, $lock) = @_;
$tmpfile = join($pathsep, $dataroot, $file);
if ($lock) {
$lockfile = join($pathsep, $dataroot, "$file.lock");
while (-e $lockfile) {}
if ( open (LOCKFILE, ">$lockfile") ) {
close LOCKFILE;
} else {
&logger::logerr("get_data: Unable to lock $tmpfile: $!");
return 0;
}
}
my @locallines;
unless($data_get_data{$tmpfile}) {
if ( open (TMPFILE, "<$tmpfile") ) {
@locallines = <TMPFILE>;
close TMPFILE;
$data_get_data{$tmpfile} = \@locallines ;
} else {
&logger::logerr("Unable to open $tmpfile for reading: $!");
}
} else {
@locallines = @{${data_get_data}{$tmpfile}} ;
}
return @locallines;
}
sub get_log {
$tmpfile = join($pathsep, $logroot, $_[0]);
open (TMPFILE, "<$tmpfile") or $msg="failed";
@locallines = <TMPFILE>;
close TMPFILE;
return @locallines;
}
sub get_madmin_client_list {
my ($clients, $fh) = @_;
$fh = (defined($fh) ? $fh : *STDOUT);
@clients = split(':', $clients);
for $i (0 .. $#clients) {
$clients[$i] =~ tr/\+/ /;
if ($clients[$i] eq $CLIENT{'clid'}) {
print $fh "<OPTION value=\"$clients[$i]\" selected>$clients[$i]</OPTION>\n";
} else {
print $fh "<OPTION value=\"$clients[$i]\">$clients[$i]</OPTION>\n";
}
}
}
sub regdusr {
my ($template) = @_;
@lines = &get_template($template);
foreach $line (@lines) {
if ($line =~ /<%=SITE.REPORTS%>/) {
&get_site_reports_list;
} elsif ($line =~ /<%=CLIENT.REPORTS%>/) {
&get_client_reports_list(undef, $SESSION{'clid'}, $SESSION{'uid'});
} elsif ($line =~ /<%=MADMIN.CLIENTS%>/) {
&get_madmin_client_list($FORM{'clid'});
} elsif ($line =~ /<%=FORM.testid%>/) {
$line =~ s/<%=FORM.testid%>/$FORM{'testid'}/;
print $line;
} else {
$line = &xlatline($line);
}
}
}
sub send_cookie {
$expdte = &format_date_time("dddd, dd-mmm-yy hh:nn:ss GMT", "1", "2592000");
print "Set-Cookie: $_[0]=$_[1]; DOMAIN=$ENV{'HTTP_HOST'}; path=/~smiadmin/; expires=$expdte\n";
}
#
# $datetimestring = &format_date_time($formatstring,$timezone,$flag,$value)
# $formatstring dd = day
# mm = month (01,02,...)
# mmm = month (Jan,Feb,...)
# yy = year (00,01,...)
# yyyy = year (2000,2001,...)
# $timezone = 1 : GMT
# 2 : Local Time
# $flag = -1 : time - 1000
# -10000 : absolute ($value)
# ??? = relative (time + $flag)
#
sub format_date_time {
$sformatted = $_[0];
if ($_[1] == '1') {
if ($_[2]=='-1') {
@tmvalues = gmtime(time-1000);
} else {
if ($_[2]=='-10000') {
@tmvalues = gmtime($_[3]);
} else {
@tmvalues = gmtime(time+$_[2]);
}
}
} else {
if ($_[2]=='-1') {
@tmvalues = localtime(time-1000);
} else {
if ($_[2]=='-10000') {
@tmvalues = localtime($_[3]);
} else {
@tmvalues = localtime(time+$_[2]);
}
}
}
$ss = sprintf( "%02d", $tmvalues[0]);
($trash, $ms) = Time::HiRes::gettimeofday();
$nn = sprintf( "%02d", $tmvalues[1]);
$h = sprintf( "%d", $tmvalues[2]);
$hh = sprintf( "%02d", $tmvalues[2]);
$dd = sprintf( "%02d", $tmvalues[3]);
$mm = sprintf( "%02d", $tmvalues[4]+1);
$mmm = format_month($tmvalues[4], "0");
$mmmm = format_month($tmvalues[4], "1");
$yy = format_year($tmvalues[5], "0");
$yyyy = format_year($tmvalues[5], "1");
$ddd = format_day_of_week($tmvalues[6], "0");
$dddd = format_day_of_week($tmvalues[6], "1");
$sformatted =~ s/ss/$ss/ig;
$sformatted =~ s/ms/$ms/ig;
$sformatted =~ s/nn/$nn/ig;
$sformatted =~ s/hh/$hh/ig;
$sformatted =~ s/h/$h/ig;
$sformatted =~ s/dddd/$dddd/ig;
$sformatted =~ s/ddd/$ddd/ig;
$sformatted =~ s/dd/$dd/ig;
$sformatted =~ s/mmmm/$mmmm/ig;
$sformatted =~ s/mmm/$mmm/ig;
$sformatted =~ s/mm/$mm/ig;
$sformatted =~ s/yyyy/$yyyy/ig;
$sformatted =~ s/yy/$yy/ig;
return $sformatted;
}
sub format_day_of_week {
@dayarray = ( ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"],
["Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday"] );
return $dayarray[$_[1]][$_[0]];
}
sub format_month {
@montharray = ( ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"],
["January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December"] );
return $montharray[$_[1]][$_[0]];
}
sub format_year {
if ($_[0] > '99') {
if ($_[1] == '0') {
return sprintf("%02d", $_[0]-100);
} else {
return sprintf("%04d", $_[0]+1900);
}
} else {
if ($_[1] == '0') {
return sprintf("%02d", $_[0]);
} else {
return sprintf("%04d", $_[0]+1900);
}
}
}
#
# returns date time values in array elements:
# 0 = seconds (0-59)
# 1 = minutes (0-59)
# 2 = hours (0-23)
# 3 = day (0-30)
# 4 = month (0-11)
# 5 = year
# 6 = day of week (0-6)
# 7 = seconds since Jan 1 1970
#
sub compute_date_time {
my ($datestring) = @_;
my @days = ('SUNDAY','MONDAY','TUESDAY','WEDNESDAY','THURSDAY','FRIDAY','SATURDAY');
my @months = ('JANUARY','FEBRUARY','MARCH','APRIL','MAY','JUNE','JULY','AUGUST','SEPTEMBER','OCTOBER','NOVEMBER','DECEMBER');
my @ampm = ('A','AM','P','PM');
my $pmflag=0;
my $tm="hns";
my $mm="mdy";
my @dtvalues=();
my @numvals=();
my @numflgs=();
my @chrs=split(//,$datestring);
my $c;
my $h="";
my $i=0;
my $j=0;
my $k=0;
my $l=0;
my $wordnum="";
my $wordstr="";
my $ignorespaces=1;
my $wordbreak=0;
foreach $c (@chrs) {
if (($c eq ' ') && ($ignorespaces)) {
next;
};
$ignorespaces=0;
if ($c =~ /([:\-\/\,\s])/ ) {
$wordbreak=1;
$ignorespaces=1;
} elsif ($c =~ /([a-zA-Z])/ ) {
if ($wordnum eq '') {
$wordstr=join('',$wordstr,"$c");
} else {
$wordbreak = 1;
$h=$c;
}
} elsif ($c =~ /([0-9])/ ) {
if ($wordstr eq '') {
$wordnum = join('',$wordnum,"$c");
} else {
$wordbreak = 1;
$h=$c;
}
} else {
}
$wordbreak = ($c eq $chrs[$#chrs]) ? 1 : $wordbreak;
if ($wordbreak) {
$wordbreak=0;
if ($wordstr ne '') {
$wordstr = uc($wordstr);
# check AMPM and TZ
if (length($wordstr) < 3) {
for $j (0..$#ampm) {
if ($ampm[$j] eq $wordstr) {
$pmflag=($ampm[$j] =~ /P/ ) ? 1: 0;
for $k (0 .. $i) {
if ($numflgs[$k] eq 'h') {
if ($pmflag) {
if ($numvals[$k] < 12) {
$numvals[$k]+=12;
}
} else {
if ($numvals[$k] > 11) {
$numvals[$k]-=12;
}
}
last;
}
}
last;
}
}
} else {
# check TZ
# check for month
for $j (0..$#months) {
if ($months[$j] =~ /$wordstr/ ) {
$numvals[$i]=$j;
$numflgs[$i]="m";
$mm =~ s/m//;
$i++;
last;
}
}
}
$wordstr="";
} else {
if ($c eq ':') {
# time element
$numflgs[$i]=substr($tm,0,1);
$tm=substr($tm,1);
} elsif (($c eq '/') || ($c eq '-')) {
# date element
$numflgs[$i]=$mm;
} else {
$j=$i-1;
if ($numflgs[$j] eq 'n') {
$numflgs[$i]="s";
$tm = s/s//;
} else {
$numflgs[$i]="?";
}
}
$numvals[$i]=$wordnum;
$wordnum="";
$i++;
}
if ($h ne '') {
if ($h =~ /([a-zA-Z])/ ) {
$wordstr=$h;
} else {
$wordnum=$h;
}
$h="";
$wordbreak = ($c eq $chrs[$#chrs]) ? 1 : 0;
}
}
}
for $j (0 .. $#numvals) {
$i = $j-1;
$k = $j+1;
if ($numflgs[$j] eq '?') {
if ($j == 0) {
if ($numflgs[$k] eq 'm') {
$numflgs[$j]="d";
$k++;
$numflgs[$k]="y";
}
} elsif ($j == 1) {
if ($numflgs[$i] eq 'm') {
$numflgs[$j]="d";
$numflgs[$k]="y";
}
} else {
if (($j == 2) && ($numflgs[$i] eq 'm')) {
$i--;
if ($numflgs[$i] eq 'mdy') {
$numflgs[$i]="d";
$i++;
}
$numflgs[$j]="y";
next;
}
if ($numflgs[$i] eq 'mdy') {
$i--;
if ($numflgs[$i] eq 'mdy') {
$numflgs[$i]="m";
$numvals[$i]--;
$i++;
$numflgs[$i]="d";
$numflgs[$j]="y";
}
} elsif ($numflgs[$i] eq 'h') {
$numflgs[$j]="n";
} elsif (length($numvals[$j]) >= 4) {
$k=length($numvals[$j]);
$l=$#numflgs+1;
for $i (0 .. $k) {
if ($i == 1) {
$numvals[$l]=substr($numvals[$j],0,2);
$numflgs[$l]="h";
$l++;
} elsif ($i == 3) {
$numvals[$l]=substr($numvals[$j],2,2);
$numflgs[$l]="n";
$l++;
} elsif ($i == 5) {
$numvals[$l]=substr($numvals[$j],4);
$numflgs[$l]="s";
}
}
$numvals[$j]="";
$numflgs[$j]="";
}
}
}
}
$dtvalues[0]=0;
$dtvalues[1]=0;
$dtvalues[2]=0;
$dtvalues[3]=0;
$dtvalues[4]=0;
$dtvalues[5]=0;
$dtvalues[6]=0;
$dtvalues[7]=0;
$j=0;
for $i (0..$#numvals) {
$dtvalue[$i]=0;
if ($numflgs[$i] eq 's') {
$dtvalues[0]=$numvals[$i];
$j+=int($numvals[$i]);
} elsif ($numflgs[$i] eq 'n') {
$dtvalues[1]=$numvals[$i];
$j+=(int($numvals[$i])*60);
} elsif ($numflgs[$i] eq 'h') {
$dtvalues[2]=$numvals[$i];
$j+=(int($numvals[$i])*3600);
} elsif ($numflgs[$i] eq 'd') {
$dtvalues[3]=$numvals[$i];
$j+=((int($numvals[$i])-1)*86400);
} elsif ($numflgs[$i] eq 'm') {
$dtvalues[4]=$numvals[$i];
} elsif ($numflgs[$i] eq 'y') {
if ($numvals[$i] < 100) {
if ($numvals[$i] > 69) {
$numvals[$i]+=1900;
} else {
$numvals[$i]+=2000;
}
}
$dtvalues[5]=$numvals[$i];
$k=int($numvals[$i])-1970;
$l=($k+2)-(($k+2) % 4);
$l=int($l/4) * 86400;
$j+=(($k*31536000)+$l);
}
}
$j+=compute_month_seconds($dtvalues[5],$dtvalues[4]);
$dtvalues[7]=$j;
return wantarray ? @dtvalues : $j;
}
sub compute_month_seconds {
my ($y,$m) = @_;
my $i;
my $n=0;
my @dpm = (0,31,28,31,30,31,30,31,31,30,31,30);
$y %= 4;
if ($y==0) {
@dpm[2]++;
}
for $i (0 .. $m) {
$n+=$dpm[$i]*86400;
}
return $n;
}
sub log_entry {
#
# Emergency fix for lost test data
#
# my ($clid, $uid) = @_;
# $tmstmp = &format_date_time("dd-mmm-yy hh:nn:ss GMT", "1", "0");
# @flds = @_;
# $j = $#flds;
# $newrec = $tmstmp;
# $newrec = join(',', $newrec, $SESSION{'tid'});
# for $i (2 .. $j) {
# $newrec = join(',', $newrec, $flds[$i++]);
# }
# $logfile = join($pathsep, $logroot, "$clid.$uid");
# if (open (TMPFILE, ">>$logfile")) {
# print TMPFILE "$newrec\n";
# close TMPFILE;
# } else {
# open (TMPFILE, ">$logfile");
# @tmprecs = <TMPFILE>;
# foreach $tmprec (@tmprecs) {
# print TMPFILE "$tmprec";
# }
# print TMPFILE "$newrec\n";
# close TMPFILE;
# }
# $chmodok = chmod 0666, $logfile;
my ($clid, $uid, $code, $message, $tmstmp) = @_;
my $i;
my $logfile;
my @tmprecs;
my $chmodok;
if (!$tmstmp) {
$tmstmp = &format_date_time("dd-mmm-yyyy hh:nn:ss.ms GMT", "1", "0");
}
my @flds = @_;
my $j = $#flds;
my $newrec = $tmstmp;
$newrec = join(',', $newrec, $SESSION{'tid'});
for $i (2 .. $j) {
$newrec = join(',', $newrec, $flds[$i++]);
}
$logfile = join($pathsep, $logroot, "$clid.$uid");
if (open (TMPFILE, ">>$logfile")) {
print TMPFILE "$newrec\n";
close TMPFILE;
} else {
open (TMPFILE, ">$logfile");
@tmprecs = <TMPFILE>;
foreach $tmprec (@tmprecs) {
print TMPFILE "$tmprec";
}
print TMPFILE "$newrec\n";
close TMPFILE;
}
$chmodok = chmod 0666, $logfile;
}
sub print_client_adminids {
my ($filterid, $fh) = @_;
$fh = (defined($fh) ? $fh : *STDOUT);
@adminids = &get_data("admin.dat");
$adminid = $adminids[0];
chop($adminid);
@lstflds = split(/&/, $adminid);
$lstidx = 0;
foreach $lstfld (@lstflds) {
if ($lstfld eq 'uid') { $uididx = $lstidx;}
elsif ($lstfld eq 'clid') { $clididx = $lstidx;}
elsif ($lstfld eq 'uac') { $uacidx = $lstidx;}
$lstidx++;
}
for (1 .. $#adminids) {
$adminid = $adminids[$_];
chop($adminid);
@lstflds = split(/&/, $adminid);
if ($lstflds[$uacidx] eq "madmin") {
$ids{$lstflds[$uididx]} = "m-$lstflds[$clididx]";
} elsif ($lstflds[$clididx] eq $filterid ) {
$ids{$lstflds[$uididx]} = "$lstflds[$clididx]";
}
}
foreach $lstid (keys(%ids)) {
print $fh "<OPTION VALUE=\"$ids{$lstid}\">$lstid</OPTION>\n";
}
@lstflds = ();
@adminids = ();
}
sub print_client_test_forms {
my ($clientID, $fh) = @_;
$fh = (defined($fh) ? $fh : *STDOUT);
$omsg = "";
opendir( DATADIR, $questionroot ) or $omsg="could not open dir $questionroot: $!";
if ($omsg ne "") {
# handle error message
#print $fh "$omsg\n";
} else {
@client_forms = grep { /$clientID.form$/ && -f "$questionroot/$_" } readdir(DATADIR);
closedir(DATADIR);
$numcforms = $#client_forms + 1;
$tests = "";
for ($i=0;$i<$numcforms;$i++) {
my ($test, $trash) = split(/\./, $client_forms[$i]);
$tests .= "\"$test\",";
}
$tests = substr($tests, 0, -1);
print $fh "\tvar forms = new Array($tests)";
}
}
sub make_group {
$grpfile = join($pathsep, $dataroot, "$_[0].groups");
open (TMPGRP, "<$grpfile") or $mustcreate = 1;
close TMPGRP;
if ($mustcreate == 1) {
$grpfilestd = join($pathsep, $dataroot, "groups.std");
&make_file($grpfile, $grpfilestd, 1);
}
}
sub get_group_owners {
@grpowners = &get_data("cnd.$_[0]");
$grpowner = shift @grpowners;
chop ($grpowner);
@grpflds = split(/&/, $grpowner);
for (1 .. $#grpflds) { $GOFIELDS{$grpflds[$_]} = $_; }
@grpflds = ();
return @grpowners;
}
sub print_group_owners {
my ($clientID, $fh, $ownedby_flag) = @_;
$fh = (defined($fh) ? $fh : *STDOUT);
@grpowners = &get_group_owners($clientID);
$idxid = $GOFIELDS{'cndid'};
$idxnmf = $GOFIELDS{'nmf'};
$idxnmm = $GOFIELDS{'nmm'};
$idxnml = $GOFIELDS{'nml'};
$idxgrpo = $GOFIELDS{'grpowner'};
for (0 .. $#grpowners) {
$grpowner = $grpowners[$_];
chop ($grpowner);
@grpdata = split(/&/, $grpowner);
$selected = "";
if ($grpdata[$idxgrpo] eq 'Y') {
if ($ownedby_flag && $grpdata[$idxid] eq $TEST{'ownedby'}) {
$selected = " SELECTED";
}
print $fh "<OPTION VALUE=\"$grpdata[$idxid]\"$selected>$grpdata[$idxnml], $grpdata[$idxnmf] $grpdata[$idxnmm]</OPTION>\n";
}
}
}
sub get_registrars {
@registrars = &get_data("cnd.$_[0]");
$registrar = shift @registrars;
chop ($registrar);
@regflds = split(/&/, $registrar);
for (1 .. $#regflds) { $REGFIELDS{$regflds[$_]} = $_; }
@regflds = ();
return @registrars;
}
sub print_registrars {
my ($clientID, $fh, $ownedby_flag) = @_;
$fh = (defined($fh) ? $fh : *STDOUT);
@registrars = &get_registrars($clientID);
$idxid = $REGFIELDS{'cndid'};
$idxnmf = $REGFIELDS{'nmf'};
$idxnmm = $REGFIELDS{'nmm'};
$idxnml = $REGFIELDS{'nml'};
$idxreg = $REGFIELDS{'registrar'};
for (0 .. $#registrars) {
$registrar = $registrars[$_];
chop ($registrar);
@regdata = split(/&/, $registrar);
$selected = "";
if ($regdata[$idxreg] eq 'Y') {
if ($ownedby_flag && $regdata[$idxid] eq $TEST{'ownedby'}) {
$selected = " SELECTED";
}
print $fh "<OPTION VALUE=\"$regdata[$idxid]\"$selected>$regdata[$idxnml], $regdata[$idxnmf] $regdata[$idxnmm]</OPTION>\n";
}
}
}
sub get_client_groups {
@grpsunsorted = &get_data( "groups.$_[0]");
$grp = shift @grpsunsorted;
@grps = sort @grpsunsorted;
@grpsunsorted = ();
chop ($grp);
@grpflds = split(/&/, $grp);
for (0 .. $#grpflds) { $GRPFIELD{$grpflds[$_]} = $_; }
@grpflds = ();
return @grps;
}
sub get_group {
@grpcnds = &get_data("cnd.$_[0]");
$grpcnd = $grpcnds[0];
chop ($grpcnd);
$grpcndflds = split(/&/, $grpcnd);
for (0 .. $#grpcndflds) { $GRPMEMFLDS{$grpcndflds[$_]} = $_;}
@grpcndflds = ();
$idxgrpid = $GRPMEMFLDS{'grpid'};
$idxmemid = $GRPMEMFLDS{'cndid'};
$idxmemnme = "$GRPMEMFLDS{'nml'}, $GRPMEMFLDS{'nmf'}, $GRPMEMFLDS{'nmm'}";
for (1 .. $#grpcnds) {
$grpcnd = $grpcnds[$_];
chop ($grp);
@grpcnddata = split(/&/, $grpcnd);
if ($grpcnddata[$idxgrpid] =~ /$_[0].$_[1]/i ) {
} else {
}
}
}
# DED 11/9/04
# send clid, grpid
# return array of cndids in group
sub get_group_cnds {
my @groups = &get_client_groups($_[0]);
my $grpid = $_[1];
foreach (@groups) {
my @grp = split(/\&/, $_);
if ($grp[1] eq "$grpid") {
my @cnds = split(/\,/,$grp[3]);
return @cnds;
}
}
}
sub get_owned_groups {
@ownedgrps = ();
@grps = &get_client_groups($_[0]);
foreach $grp (@grps) {
if ($grp =~ /$_[0].$_[1].(\.\*)\&/i ) {
push @ownedgrps, $grp;
}
}
@grps = ();
return @ownedgrps;
}
sub print_client_groups {
my ($clientID, $fh) = @_;
$fh = (defined($fh) ? $fh : *STDOUT);
@cligrps = &get_client_groups($clientID);
$idxid = $GRPFIELD{'grpid'};
$idxdesc = $GRPFIELD{'grpdesc'};
for (0 .. $#cligrps) {
$grp = $cligrps[$_];
chop ($grp);
@grpdata = split(/&/, $grp);
print $fh "<OPTION VALUE=\"$grpdata[$idxid]\">$grpdata[$idxdesc]\n";
}
}
sub print_owned_groups {
@cligrps = &get_owned_groups($_[0], $_[1]);
my $fh = (defined($_[2]) ? $_[2] : *STDOUT);
$idxid = $GRPFIELD{'grpid'};
$idxdesc = $GRPFIELD{'grpdesc'};
for (1 .. $#cligrps) {
$grp = $cligrps[$_];
chop ($grp);
@grpdata = split(/&/, $grp);
print $fh "<OPTION VALUE=\"$grpdata[$idxid]\">$grpdata[$idxdesc]\n";
}
}
$SYSTEM{'years'} = "<OPTION VALUE=\"2002\">2002
<OPTION VALUE=\"2003\">2003
<OPTION VALUE=\"2004\">2004
<OPTION VALUE=\"2005\">2005
<OPTION VALUE=\"2006\">2006
<OPTION VALUE=\"2007\">2007
<OPTION VALUE=\"2008\">2008
<OPTION VALUE=\"2009\">2009
";
$SYSTEM{'months'} = "<OPTION VALUE=\"01\">Jan
<OPTION VALUE=\"02\">Feb
<OPTION VALUE=\"03\">Mar
<OPTION VALUE=\"04\">Apr
<OPTION VALUE=\"05\">May
<OPTION VALUE=\"06\">Jun
<OPTION VALUE=\"07\">Jul
<OPTION VALUE=\"08\">Aug
<OPTION VALUE=\"09\">Sep
<OPTION VALUE=\"10\">Oct
<OPTION VALUE=\"11\">Nov
<OPTION VALUE=\"12\">Dec
";
$SYSTEM{'days'} = "<OPTION VALUE=\"01\">01
<OPTION VALUE=\"02\">02
<OPTION VALUE=\"03\">03
<OPTION VALUE=\"04\">04
<OPTION VALUE=\"05\">05
<OPTION VALUE=\"06\">06
<OPTION VALUE=\"07\">07
<OPTION VALUE=\"08\">08
<OPTION VALUE=\"09\">09
<OPTION VALUE=\"10\">10
<OPTION VALUE=\"11\">11
<OPTION VALUE=\"12\">12
<OPTION VALUE=\"13\">13
<OPTION VALUE=\"14\">14
<OPTION VALUE=\"15\">15
<OPTION VALUE=\"16\">16
<OPTION VALUE=\"17\">17
<OPTION VALUE=\"18\">18
<OPTION VALUE=\"19\">19
<OPTION VALUE=\"20\">20
<OPTION VALUE=\"21\">21
<OPTION VALUE=\"22\">22
<OPTION VALUE=\"23\">23
<OPTION VALUE=\"24\">24
<OPTION VALUE=\"25\">25
<OPTION VALUE=\"26\">26
<OPTION VALUE=\"27\">27
<OPTION VALUE=\"28\">28
<OPTION VALUE=\"29\">29
<OPTION VALUE=\"30\">30
<OPTION VALUE=\"31\">31
";
$SYSTEM{'hours'} = "<OPTION VALUE=\"1\">1
<OPTION VALUE=\"2\">2
<OPTION VALUE=\"3\">3
<OPTION VALUE=\"4\">4
<OPTION VALUE=\"5\">5
<OPTION VALUE=\"6\">6
<OPTION VALUE=\"7\">7
<OPTION VALUE=\"8\">8
<OPTION VALUE=\"9\">9
<OPTION VALUE=\"10\">10
<OPTION VALUE=\"11\">11
<OPTION VALUE=\"12\">12
";
$SYSTEM{'minutes'} = "<OPTION VALUE=\"00\">00
<OPTION VALUE=\"5\">05
<OPTION VALUE=\"10\">10
<OPTION VALUE=\"15\">15
<OPTION VALUE=\"20\">20
<OPTION VALUE=\"25\">25
<OPTION VALUE=\"30\">30
<OPTION VALUE=\"35\">35
<OPTION VALUE=\"40\">40
<OPTION VALUE=\"45\">45
<OPTION VALUE=\"50\">50
<OPTION VALUE=\"55\">55
";
$SYSTEM{'pmoffset'} = "<OPTION VALUE=\"00\">AM
<OPTION VALUE=\"12\">PM
";
# <ACTSEMBED='filename' ALIGN=TOP|BOTTOM|INSERT NUMBER=BEFORE|AFTER>
sub merg_exhibit_in_text {
$beginKeep = 0;
$tmptext = $_[0];
$findtext = "<ACTSEMBED=(.*)>";
if ($tmptext =~ /$findtext/i ) {
$findtext = "<ACTS";
($toptext,$exhcmd) = split(/$findtext/, $tmptext);
($exhcmd,$bottomtext) = split(/>/, $exhcmd);
lc($exhcmd);
@parms = split(/ /, $exhcmd);
foreach $parm (@parms) {
$parm =~ s/ //g;
($nme,$vlu) = split(/=/, $parm);
if (($nme ne '') && ($vlu ne '')) {
lc($nme);
lc($vlu);
$EXHIBIT_PARM{$nme} = $vlu;
}
}
if ($EXHIBIT_PARM{'EMBED'} ne '') {
$prefile = join($pathsep, $questionroot, "actsexhibit", $EXHIBIT_PARM{'EMBED'});
$exhfile = &file_exists_with_extension($prefile, "htt;htm;html");
if ($exhfile ne '') {
open(EXHFILE, "<$exhfile");
@exhlines = <EXHFILE>;
close EXHFILE;
$instext = "\n";
foreach $exhline (@exhlines) {
if ($exhline =~ /<BODY/i) {
$beginKeep=1;
} else {
if ($beginKeep) {
if ($exhline =~ /BODY>/i) {
$beginKeep=0;
} else {
$instext = join('', $instext, $exhline);
}
}
}
}
if ($EXHIBIT_PATM{'align'} eq 'bottom') {
$tmptext = join('', $_[0], $instext);
} elsif ($EXHIBIT_PATM{'align'} eq 'insert') {
$tmptext = join('', $toptext, $instext, $bottomtext);
} else {
$tmptext = join('', $instext, $_[0]);
}
}
}
}
return $tmptext;
}
# @phrases = &get_phrases(_LANGUAGE_ID);
sub get_phrases {
my ($lang) = @_;
$tmpfile = join($pathsep, $secroot, "language", "phrases.$lang");
if ( ! open (TMPFILE, "<$tmpfile") ) {
&logger::logerr("Unable to read $tmpfile: $!");
return ();
}
@locallines = <TMPFILE>;
close TMPFILE;
return @locallines;
}
# @phrases = &put_phrases($languageid);
sub put_phrases {
$tmpfile = join($pathsep, $secroot, "language", "phrases.$_[0]");
open (TMPFILE, ">$tmpfile") or return 0;
for (0 .. $#sTranslation) {
print TMPFILE "$sTranslation[$_]\n";
}
close TMPFILE;
return 1;
}
#
# $access = &ipfilteredaccess($filtermasks, $visitorip);
#
# RETURNS 0 = access denied
# 1 = access permitted
#
# ipaddress filters can be submitted in pairs separated by a comma
# xxxx:nnn.sss.bbb.mmm,xxxx:nnn.sss.bbb.mmm
# x = A (absolute match of segment required)
# x = M (masked LOGICAL AND match of segment required)
# if x is omitted, all segments are treated as masked.
#
sub ipfilteredaccess {
my $visitor = $_[1];
my $visitortocheck = $_[1];
my @filters = split(/\,/, $_[0]);
my @rslt = ();
my @filtersegs = ();
my @applymask = ();
my @visitsegs = split(/\./, $visitor);
my $filter = "";
foreach $filter (@filters) {
(my $segeval, my $ipmask) = split(/:/, lc($filter));
if ($ipmask eq '') { $ipmask = $segeval; $segeval="MMMM";}
@filtersegs = split(/\./, $ipmask);
@applymask = split(//,$segeval);
for (0 .. $#filtersegs) {
use integer;
if ($applymask[$_] eq "A") {
@rslt[$_] = ($visitsegs[$_] eq $filtersegs[$_]) ? $visitsegs[$_] : 0;
} elsif ($applymask[$_] eq "M") {
@rslt[$_] = int($visitsegs[$_]) & int($filtersegs[$_]);
} else {
@rslt[$_] = 0;
}
}
$visitor = "$rslt[0].$rslt[1].$rslt[2].$rslt[3]";
@rslt = ();
@filtersegs = ();
@applymask = ();
if ($visitor eq $visitortocheck) {
@filters = ();
return 1;
}
}
@filters = ();
return 0;
}
## v support for self-registration
sub setbrowsertype {
$SESSION{'useragent'}=$ENV{'HTTP_USER_AGENT'};
if ($FORM{'browser'} eq '') {
if ($SESSION{'useragent'} =~ /MSIE/ ) {
$FORM{'browser'} = "MSIE/4";
} else {
$FORM{'browser'} = "NSNV/4";
}
}
($SESSION{'browserapp'}, $SESSION{'browserversion'}) = split(/\//, $FORM{'browser'});
}
## ^ support for self-registration
## v sac modification to standardize test sequence inputs
sub print_client_seqtst_list {
my ($clid, $tseq, $tdefault, $fh) = @_;
$fh = (defined($fh) ? $fh : *STDOUT);
my @recs=();
my @trecs=();
my $grepfor;
my $rec;
my $id;
my $desc;
my $tmd;
my $maxtm;
my $seq;
my $etc;
my $html;
my $selected="";
if ($tseq eq 'cfa') {
$grepfor="(.*)\&cfa\&(.*)";
} elsif (($tseq eq 'profb') || ($tseq eq 'profa')) {
$grepfor="(.*)\&(std|svy|dmg|adp)\&(.*)";
} elsif ($tseq eq 'srvy') {
$grepfor="(.*)\&(std|svy|dmg|adp)\&(.*)";
}
@recs = &get_data("tests.$clid");
$rec = shift @recs;
if ($#recs != -1) {
@trecs=grep( /$grepfor/, @recs);
if ($#trecs != -1) {
@recs=();
foreach $rec (@trecs) {
($id,$desc,$tmd,$maxtm,$seq,$etc)=split(/&/, $rec);
if (($grepfor =~ /$seq/i) && ($id ne $TEST{'id'})) {
$rec = join('&',$desc,$id);
push @recs, $rec;
}
}
if ($#recs != -1) {
@trecs=@recs;
@recs = sort @trecs;
@trecs=();
}
}
}
$seq = ($tseq eq 'cfa') ? 'dscl' : $tseq;
$html="<select name=\"$seq\">\n";
foreach $rec (@recs) {
($desc,$id)=split(/&/, $rec);
$selected = ($id eq $tdefault) ? " selected" : "";
$html= join('',$html,"<option value=\"$id\"$selected>$desc\n");
@flds=();
}
if ($tdefault eq '') {
$html= join('',$html,"<option value=\"\" selected>None\n");
} else {
$html= join('',$html,"<option value=\"\">None\n");
}
$html= join('',$html,"</select><br>\n");
return $html;
}
## ^ sac modification to standardize test sequence inputs
sub print_user_language_select {
my ($clid, $dropdown) = @_;
@allowed_langs = split(/,/, $SYSTEM{'ALLOWEDLANGS'});
if ($CLIENT{'cllangflags'} eq "Y" && $dropdown != 1) {
print "$xlatphrase[541]<BR>\n";
foreach $lang (@allowed_langs) {
print "<a href=\"#top\" name=\"$LANGUAGE_ID{$lang}\" onClick=\"return language_select('$lang')\">\n";
print "<img src=\"$graphroot/$LANGUAGE_FLAG{$lang}\" border=0 Alt=\"$LANGUAGE_ID{$lang}\"></a>\n";
}
} else {
print "&nbsp;$xlatphrase[833]&nbsp;<BR>\n";
print "<SELECT NAME=\"sellang\" onChange=\"return language_select(this.value)\">\n";
foreach $lang (@allowed_langs) {
$selected = ($lang eq $FORM{'lang'}) ? " SELECTED" : "";
print " <OPTION VALUE=\"$lang\"$selected>$LANGUAGE_ID{$lang}</OPTION>\n";
}
print "</SELECT>\n";
}
}
sub print_client_forsale_table {
my ($clid, $order) = @_;
my $total = 0;
print "<TABLE BORDER=1>\n";
print "<TR>\n";
if ($order == 0) {
print "\t<TH>Purchase</TH>";
}
print "<TH>Item</TH><TH>Price</TH><TH>Duration</TH>\n";
print "</TR>\n";
### tstid&tname&description&cost&duration
@forsale = &get_data("forsale.".$CLIENT{'clid'});
shift(@forsale);
my $i=0;
my $orderlist="";
foreach $item (@forsale) {
@details = split('\&', $item);
if ($order == 1 ) {
if ($FORM{"checkbox".$i++} eq $details[0]) {
$orderlist .= "$details[0]\;";
} else {
next;
}
}
print "<TR>\n";
if ($order == 0) {
print "\t<TD align=center>\n";
print "\t\t<input type=checkbox name=checkbox".$i++." value=$details[0]>\n";
print "\t</TD>\n";
} else {
$total += $details[4];
}
print "\t<TD>\n";
print "\t\t<b>$details[2]</b><br>\n";
print "\t\t$details[3]\n";
print "\t</TD>\n";
print "\t<TD align=center>\n";
print "\t\t".sprintf("&nbsp;\$%0.2f", $details[4])."&nbsp;\n";
print "\t</TD>\n";
print "\t<TD align=center>\n";
if ($details[5] == 365) {
print "\t\t1 year\n";
} else {
print "\t\t$details[5] days\n";
}
print "\t</TD>\n";
print "</TR>\n";
}
if ($order == 1) {
$total = sprintf("%0.2f", $total);
print "<TR>\n";
print "\t<TD colspan=3 align=right>\n";
print "\t\t<b>Total:</b>&nbsp;\n";
print "\t\t\$$total\n";
print "\t</TD>\n";
print "</TR>\n";
print "</TABLE>\n";
print "<INPUT TYPE=HIDDEN NAME=\"OrderID\" VALUE=\"\">\n";
print "<INPUT TYPE=HIDDEN NAME=\"total\" VALUE=\"$total\">\n";
print "<INPUT TYPE=HIDDEN NAME=\"orderlist\" VALUE=\"$orderlist\">\n";
$url = "https://".$ENV{'SERVER_NAME'};
if ($ENV{'SERVER_PORT'} != 443) {
$url .= ":".$ENV{'SERVER_PORT'};
}
$url .= "/cgi-bin/shop.pl";
print "<INPUT TYPE=HIDDEN NAME=URL VALUE=$url>\n";
} else {
print "</TABLE>\n";
}
}
## v sac relocated and renamed general support functions
# originally named sub get_file_to_html_string{ moved from tstart.pl
sub get_file_html_body {
my($filename) = @_;
my $exhline;
open(AFILE, "<$filename");
my @exhlines = <AFILE>;
close AFILE;
my $instext ='';
foreach $exhline (@exhlines) {
$instext = join('',$instext ,$exhline);
}
$instext =~ s/(.*)\<body(.*)\>(.*)\<\/body(.*)/$3/ig;
return $instext;
}
## ^ sac relocated and renamed general support functions
sub make_tree {
my ($dirtree) = @_;
my $dirbase=$docroot;
my $dirbranch = $dirtree;
my $dirbranch = s/^$docroot//g;
my @branches=split($pathsep,$dirbranch);
&dbgprint("make_tree:$dirbase:$dirtree:$dirbranch:$#branches\n");
for $i (0 .. $#branches) {
$dirbranch=join($pathsep,$dirbase,$branches[$i]);
if (opendir(TMPDIR,"$dirbranch")) {
closedir TMPDIR;
} else {
mkdir $dirbranch,0666;
&dbgprint("mkdirResult:$dirbranch:$!\n");
}
$dirbase=$dirbranch;
}
}
sub get_last_cnd_action { #Basically, this just gets the timestamp
#of the last action a candidate does by
#looking at his logfile.
#Example: &get_last_cnd_action($account_name, $candidate_name);
my $acct_nombre = $_[0]; #Get client's account name
#into something more permanent
my $cnd_nombre = $_[1]; #Get the candidate name to check
#last login date.
my $cnd_logfile = "../secure_html/log/$acct_nombre.$cnd_nombre"; #logfile relative to cgi-bin
my @fileinfo = stat($cnd_logfile); #Holds the file info.
my $file_mtime = $fileinfo[9]; #mtime value of the log file
return $file_mtime;
}
sub compare_time { #Compares a logfile's timestamp to time()
#Takes values: client ID, file_mtime (returned
#from &get_last_cnd_action), and time_delimiter
#(Number of days to check against, like 30, 60,
#etc). This should be passed in the POST/GET.
# Example: &compare_time(clid, file_mtime,
# time_delimiter);
#Returns client_id if it passes, else nothing.
my $client_id = $_[0]; #get client ID
my $file_time = $_[1]; #get mtime
my $time_delimiter = $_[2]; #get delimiter (no. of days)
$file_time = int(((($file_time/60)/60)/24)); #change it into days
my $localtime = time; #First step is to get the current time in days
$localtime = int(((($localtime/60)/60)/24)); #change it into days
my $difference = $localtime - $file_time; #find their difference
#Do the simple checking...
return $client_id unless ($difference > $time_delimiter);
}
my %get_a_key_data = () ;
sub get_a_key {
#gets a hash:key value from a file
#like cnd.clientid or something
#Example: &get_a_key(filename, cndID, hash_key);
#takes filename(the file that holds the
#stuff to parse), cndid (candidate
#name/id), and hash_key(basically, the
#field at the top of the file seperated
#by &). Returns the value of hash_key
my $match = $_[1];
my $magic_key = $_[2];
my $key_file = $_[0] ;
unless ($get_a_key_data{$key_file}) {
my @searching = &get_data($key_file);
my $getlegend = shift(@searching);
chomp($getlegend);
my @labels = split( '&', $getlegend);
my @fields = ();
my %megahash =();
foreach (@searching) {
chomp $_;
@fields = split( '&', $_);
my $hashlength = $#fields;
my $betty;
foreach $betty (0..$hashlength) {
$get_a_key_data{$key_file}->{$fields[0]}->{$labels[$betty]} = $fields[$betty] ;
}
}
}
return $get_a_key_data{$key_file}->{$match}->{$magic_key} ;
}
sub print_clcnd_input {
my ($clid, $clcndid, $flag, $print) = @_;
$cnd = 'cnd'.$clcndid;
$clcnd = 'clcnd'.$clcndid;
$clcndvals = 'clcnd'.$clcndid."vals";
$clcndformat = 'clcnd'.$clcndid."format";
if ($flag eq "f") {
$flag = " onChange='set_change_flag()'";
} else {
$flag = "";
}
$output = "<TR>\n";
if ($CLIENT{$clcndvals} ne "") {
my @vals = split(/\,/, $CLIENT{$clcndvals});
if ($CLIENT{$clcndformat} eq "radio") {
### Print radio buttons based on clcnd values
$output .= "\t<TD COLSPAN=2 ALIGN=\"left\" VALIGN=\"middle\" NOWRAP>\n";
$output .= "\t\t<FONT SIZE=2>\n";
$output .= "\t\t\t$CLIENT{$clcnd}\n";
$output .= "\t\t</FONT>\n";
$output .= "\t</TD>\n";
$output .= "</TR>\n";
$output .= "<TR>\n";
$output .= "\t<TD ALIGN=\"right\" VALIGN=\"middle\" NOWRAP>\n";
$output .= "\t\t&nbsp;\n";
$output .= "\t</TD>\n";
$output .= "\t<TD ALIGN=\"left\" VALIGN=\"middle\" NOWRAP>\n";
$output .= "\t\t<FONT SIZE=2>\n";
foreach $val (@vals) {
if ($val eq $CANDIDATE{$cnd}) {
$output .= "\t\t\t<INPUT TYPE=\"RADIO\" NAME=\"$cnd\" VALUE=\"$val\" CHECKED$flag> $val<BR>\n";
} else {
$output .= "\t\t\t<INPUT TYPE=\"RADIO\" NAME=\"$cnd\" VALUE=\"$val\"$flag> $val<BR>\n";
}
}
$output .= "\t\t</FONT>\n";
$output .= "\t</TD>\n";
} else {
### Print select box based on clcnd values
$output .= "\t<TD ALIGN=\"right\" VALIGN=\"middle\" NOWRAP>\n";
$output .= "\t\t<FONT SIZE=2>\n";
$output .= "\t\t\t$CLIENT{$clcnd}&nbsp;\n";
$output .= "\t\t</FONT>\n";
$output .= "\t</TD>\n";
$output .= "\t<TD ALIGN=\"left\" VALIGN=\"middle\" NOWRAP>\n";
$output .= "\t\t<FONT SIZE=2>\n";
unshift(@vals, "");
$output .= "\t\t\t<SELECT NAME=\"$cnd\"$flag>\n";
foreach $val (@vals) {
if ($val eq $CANDIDATE{$cnd}) {
$output .= "\t\t\t\t<OPTION value=\"$val\" SELECTED>$val</OPTION>\n";
} else {
$output .= "\t\t\t\t<OPTION value=\"$val\">$val</OPTION>\n";
}
}
$output .= "\t\t\t</SELECT>\n";
$output .= "\t\t</FONT>\n";
$output .= "\t</TD>\n";
}
} else {
### Print regular input box
$output .= "\t<TD ALIGN=\"right\" VALIGN=\"middle\" NOWRAP>\n";
$output .= "\t\t<FONT SIZE=2>\n";
$output .= "\t\t\t$CLIENT{$clcnd}&nbsp;\n";
$output .= "\t\t</FONT>\n";
$output .= "\t</TD>\n";
$output .= "\t<TD ALIGN=\"left\" VALIGN=\"middle\" NOWRAP>\n";
$output .= "\t\t<FONT SIZE=2>\n";
$output .= "<INPUT TYPE=TEXT NAME=\"$cnd\" SIZE=30 MAXLENGTH=30 VALUE=\"$CANDIDATE{$cnd}\"$flag>\n";
$output .= "\t\t</FONT>\n";
$output .= "\t</TD>\n";
}
$output .= "</TR>\n";
if ($print) {
print $output;
} else {
return $output;
}
}
sub makecndhash { #makes an md5hash out of some info. Takes 2
#arguments, each part of the source to generate #the hash. Returns the hash value.
#Example: &makecndhash('paul', '67847');
use Digest::MD5;
my $length = 16;
my $tempstring = 'j0Hx4b2uXx8';
my $data = "$_[0]:$tempstring:$_[1]";
my $ctx = Digest::MD5->new;
$ctx->add($data);
my $digest = $ctx->hexdigest;
my $fragment = substr $digest, 0, $length;
$fragment =~ s/..../$&-/g;
$fragment =~ s/-$//g;
return $fragment;
}
sub popEmlAcl {
my $clid = $_[0];
my $tempstring;
my @searching = get_data("$clid.emlacl");
foreach (@searching) {
chomp($_);
$tempstring .= $_ . "," unless /^(#|\n|\s|$)/;#gets out comments and blank lines
}
$tempstring =~ s/\,$//g;
my @returnarray = split(/\,/, $tempstring);
return @returnarray;
}
sub pushEmlAcl {
my $clid = $_[0];
my $recstr = $_[1];
my $tempstring;
my @searching = get_data("$clid.emlacl");
foreach (@searching) { #First we keep comments
chomp($_);
if (/^(#|$)/) {
$tempstring .= "$_,";
}
}
$tempstring .= $recstr;
my @pusharray = split(/\,/, $tempstring);
$trash = join( $pathsep, $dataroot, "$clid.emlacl");
open( EMLACLFILE, ">$trash" ) or die "$trash not found! $!";
foreach (@pusharray) {
print EMLACLFILE "$_\n";
}
close EMLACLFILE;
}
# end with True because this is a require file
1