#!/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/; # use Data::Dumper; my $HBI_Debug_smilib_show_template = 0 ; my $HBI_Debug_smilib_template_file = 1 ; 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 = ; 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 = ; 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 "\n"; } } $reqmeth = $ENV{'REQUEST_METHOD'}; if ($reqmeth =~ /POST/i) { read (STDIN, $qstr, $ENV{'CONTENT_LENGTH'}); if ($debugon) { &dbgprint("POSTED = $qstr\n"); } else { print "\n"; } } } sub show_message_with_close { print "
$_[0]


"; } ### 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 "
$_[0]

\n"; if ($_[1] == 2) { print "BACK\n"; } else { print "BACK\n"; } print " "; } 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)); my $HBI_Debug_Form = 1 ; # parse request parameters into variables $query = new CGI; %FORM = $query->Vars; if ($HBI_Debug_Form) { my $key ; warn "Dump FORM " ; foreach $key (sort keys %FORM) { warn "Key ${key} Val $FORM{${key}} X\n" ; } warn "End Dump FORM " ; } #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 "
File successfully copied...
"; return 1; } sub make_file { if ( ! open (TMPFILE, "<$_[1]") ) { &logger::logerr("Unable to open $_[1] for reading: $!\n"); return 0; } @copylines = ; 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 = ; 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 = ; 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. $session_id =~ tr/\000/,/ ; # Replace a null with a comma. my $err_mesg = "HBI Bad Y Session id $session_id X " . length $session_id . " Z" ; warn $err_mesg ; $session_id =~ s/\,.*$// ; # Drop any comma and the fo;;owing characters. } $trash = join($pathsep, $logroot, "sess.$session_id"); open (SESSFILE, "<$trash"); @sessrecs = ; close SESSFILE; if ($#sessrecs == -1) { &show_illegal_access_warning unless ($skip_warning); warn "HBI No Lines in Session file, $trash ." ; 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 "\n"; print "\n"; print "\ 
\n"; if ($user eq "user") { print "Attention User:
\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.
\n"; } else { print "Attention Site Administrators:
\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.
\n"; } print "\ 
\n"; print "\ 
\n"; # print "Attention Hackers:
You have attempted to gain access to this secure site \n"; # print "by bypassing the site security.
\n"; # print "\ 
\n"; # print "The contents of this site are protected by United States and International copyright laws.
\n"; # print "The information on this site is proprietary and protected by United States and International information privacy laws.
\n"; # print "\ 
\n"; # print "This invalid attempt has been logged, the site administrator notified, and your access route traced.
"; # print "Any further unauthorized access attempts from $ENV{'REMOTE_ADDR'} will result "; # print "in further investigation and possible prosecution.
\n"; print "\n"; print "\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 = ; # 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 = ; 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 = ; 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; } } while ($xltline =~ /<%=QUESTIONS_AH\.([0-9]+)\.(.+)%>/ ) { my $ques_num = $1 ; my $ques_index = $ques_num - 1 ; my $ques_key = $2 ; # warn "Found QUESTIONS_AH num $ques_num index $ques_index key $ques_key \n" ; $repl = ${$QUESTIONS_AH}[$ques_index]->{$ques_key} ; if ($OUTPUT_Format eq "RTF") {$repl =~ s/\/\\par /ig ;} $repl = &escape_special_chars( $repl ) if ( $escapem == 1 ) ; $srch = "<%=QUESTIONS_AH." . $ques_num . "." . $ques_key . "%>" ; $xltline =~ s/$srch/$repl/g ; } while ($xltline =~ /<%=QUESTIONS_AG\.([0-9]+)\.(.+)%>/ ) { my $ques_num = $1 ; my $ques_index = $ques_num - 1 ; my $ques_key = $2 ; # warn "Found QUESTIONS_AG num $ques_num index $ques_index key $ques_key \n" ; $repl = ${$QUESTIONS_AG}[$ques_index]->{$ques_key} ; if ($OUTPUT_Format eq "RTF") {$repl =~ s/\/\\par /ig ;} $repl = &escape_special_chars( $repl ) if ( $escapem == 1 ) ; $srch = "<%=QUESTIONS_AG." . $ques_num . "." . $ques_key . "%>" ; $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 "