#!/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 = <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> \ <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> \ <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)); 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 "<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. $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 = <SESSFILE>; 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 "<HTML>\n"; print "<BODY>\n"; print "\ <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 "\ <BR>\n"; print "\ <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 "\ <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 "\ <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; } } 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/\<br\>/\\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/\<br\>/\\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 "<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; if ($HBI_Debug_smilib_template_file) { warn "Reading Template file $tmpfile \n"; } # 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'}); } warn "HBI Debug Template file $base " if ($HBI_Debug_smilib_show_template) ; @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"; } } } # Hashs to keep in-memory copies of data files. # %data_get_data uses a file name for a key, and the value # is a copy of the data file. # %mtime_get_data uses the same key and the value is a # time value for the last known change to the file. my %mtime_get_data = () ; 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; my $local_mtime ; my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) ; unless($data_get_data{$tmpfile}) { if ( open (TMPFILE, "<$tmpfile") ) { @locallines = <TMPFILE>; ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $local_mtime, $ctime, $blksize, $blocks) = stat TMPFILE ; close TMPFILE; $mtime_get_data{$tmpfile} = $local_mtime ; $data_get_data{$tmpfile} = \@locallines ; } else { &logger::logerr("Unable to open $tmpfile for reading: $!"); } } else { ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $local_mtime, $ctime, $blksize, $blocks) = stat $tmpfile ; if ($local_mtime > $mtime_get_data{$tmpfile}) { # Replace the data values. if ( open (TMPFILE, "<$tmpfile") ) { @locallines = <TMPFILE>; ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $local_mtime, $ctime, $blksize, $blocks) = stat TMPFILE ; $mtime_get_data{$tmpfile} = -- $local_mtime ; $data_get_data{$tmpfile} = \@locallines ; close TMPFILE; utime $atime, $local_mtime , $tmpfile ; } 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=\"2009\">2009 <OPTION VALUE=\"2010\">2010 <OPTION VALUE=\"2011\">2011 <OPTION VALUE=\"2012\">2012 <OPTION VALUE=\"2013\">2013 <OPTION VALUE=\"2014\">2014 <OPTION VALUE=\"2015\">2015 <OPTION VALUE=\"2016\">2016 <OPTION VALUE=\"2017\">2017 <OPTION VALUE=\"2018\">2018 <OPTION VALUE=\"2019\">2019 <OPTION VALUE=\"2020\">2020 <OPTION VALUE=\"2021\">2021 <OPTION VALUE=\"2022\">2022 <OPTION VALUE=\"2023\">2023 <OPTION VALUE=\"2024\">2024 <OPTION VALUE=\"2025\">2025 <OPTION VALUE=\"2026\">2026 <OPTION VALUE=\"2027\">2027 <OPTION VALUE=\"2028\">2028 <OPTION VALUE=\"2029\">2029 <OPTION VALUE=\"2030\">2030 "; $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 " $xlatphrase[833] <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(" \$%0.2f", $details[4])." \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> \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 \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} \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} \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; } sub get_data_hash { # Read a data file, and return a hash of the file. # Parameters are the file name, and a flag for using a lock file. # Return an unnamed hash of hashes. # The keys of the first hash are the ids. # The values of the first hash is a hash with one line's data. # This next hash has the field ids for keys. my ($file, $lock) = @_; my @data_lines = get_data($file, $lock) ; my $bFirst = 1 ; my %DATA = () ; my %FIELDS = () ; my %ROWS = () ; foreach $datadef (@data_lines) { chop ($datadef); if ($bFirst eq 1) { # First line only. @flds = split(/&/, $datadef); # Validate field ids, no duplicates. foreach $fld (@flds) { if ($FIELDS{$fld}) { warn "Duplicate field id, $fld, in file $file ." ; } else { $FIELDS{$fld} = 1 ; } } $bFirst = 0; } else { # Second and later lines. my ($id) = split(/&/, $datadef); if ($ROWS{$id}) { warn "Duplicate row id value $id, in file $file ." ; } else { $ROWS{$id} = 1 ; } # warn "ID $id DATALINE $datadef X\n" ; @rowdata = split(/&/, $datadef); if ($#rowdata > $#flds) { warn "More data fields than field ids, in file $file ." ; } $counter = 0; foreach $fld (@flds) { $DATA{$id}->{$fld} = $rowdata[$counter] ; $counter ++ ; } } # End of if $bFirst. } # foreach return \%DATA ; } # end with True because this is a require file 1