You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2750 lines
74 KiB
2750 lines
74 KiB
4 months ago
|
#!/usr/bin/perl
|
||
|
|
#
|
||
|
|
# $Id: smilib.pl,v 1.51 2006/11/28 21:07:48 psims Exp $
|
||
|
|
#
|
||
|
|
# Source File: smilib.pl
|
||
|
|
|
||
|
|
require 'sitecfg.pl';
|
||
|
|
use POSIX;
|
||
|
|
use Time::HiRes;
|
||
|
|
use CGI qw/:standard/;
|
||
|
|
|
||
|
|
sub get_client_configuration {
|
||
|
|
$omsg = "not found";
|
||
|
|
if ($_[0]) {
|
||
|
|
$trash = join( $pathsep, $dataroot, "config.$_[0]");
|
||
|
|
$omsg = "";
|
||
|
|
open( CFGFILE, "<$trash" ) or $omsg="not found";
|
||
|
|
}
|
||
|
|
if ($omsg eq 'not found') {
|
||
|
|
$trash = join( $pathsep, $dataroot, "config.$SESSION{'clid'}");
|
||
|
|
$omsg = "";
|
||
|
|
open( CFGFILE, "<$trash" ) or $omsg="not found";
|
||
|
|
}
|
||
|
|
if ($omsg eq 'not found') {
|
||
|
|
$trash = join( $pathsep, $dataroot, "config.std");
|
||
|
|
open( CFGFILE, "<$trash" ) or return;
|
||
|
|
}
|
||
|
|
@cfgentries = <CFGFILE>;
|
||
|
|
close CFGFILE;
|
||
|
|
for (0 .. $#cfgentries) {
|
||
|
|
chop ($cfgentries[$_]);
|
||
|
|
($entrykey,$entryvalue) = split(/=/, $cfgentries[$_]);
|
||
|
|
$SYSTEM{$entrykey} = $entryvalue;
|
||
|
|
}
|
||
|
|
if (($SESSION{'clid'} ne 'sacc') && ($SESSION{'clid'} ne 'std')) {
|
||
|
|
$SYSTEM{'languagesupport'} = ($SYSTEM{'ALLOWEDLANGS'} eq '' || $SYSTEM{'ALLOWEDLANGS'} =~ /none/) ? "FALSE" : "TRUE";
|
||
|
|
} else {
|
||
|
|
$SYSTEM{'languagesupport'} = "TRUE";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub put_client_configuration {
|
||
|
|
$omsg = "not found";
|
||
|
|
if ($_[0]) {
|
||
|
|
$trash = join( $pathsep, $dataroot, "config.$_[0]");
|
||
|
|
$omsg = "";
|
||
|
|
open( CFGFILE, "<$trash" ) or $omsg="not found";
|
||
|
|
}
|
||
|
|
if ($omsg eq 'not found') {
|
||
|
|
$trash = join( $pathsep, $dataroot, "config.$SESSION{'clid'}");
|
||
|
|
$omsg = "";
|
||
|
|
open( CFGFILE, "<$trash" ) or $omsg="not found";
|
||
|
|
}
|
||
|
|
if ($omsg eq 'not found') {
|
||
|
|
$trash = join( $pathsep, $dataroot, "config.std");
|
||
|
|
open( CFGFILE, "<$trash" ) or return;
|
||
|
|
}
|
||
|
|
@cfgentries = <CFGFILE>;
|
||
|
|
close CFGFILE;
|
||
|
|
for (0 .. $#cfgentries) {
|
||
|
|
chop ($cfgentries[$_]);
|
||
|
|
($entrykey,$entryvalue) = split(/=/, $cfgentries[$_]);
|
||
|
|
$key = "C$entrykey";
|
||
|
|
$key =~ s/ /+/g;
|
||
|
|
if ($FORM{$key} ne '') {
|
||
|
|
$cfgentries[$_] = "$entrykey=$FORM{$key}";
|
||
|
|
} else {
|
||
|
|
if ( $entrykey eq 'IP_ACCESS_FILTER') {
|
||
|
|
$cfgentries[$_] = "$entrykey=$FORM{'CIP_ACCESS_FILTER'}";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$omsg = "not found";
|
||
|
|
if ($_[0]) {
|
||
|
|
$trash = join( $pathsep, $dataroot, "config.$_[0]");
|
||
|
|
$omsg = "";
|
||
|
|
open( CFGFILE, ">$trash" ) or $omsg="not found";
|
||
|
|
}
|
||
|
|
if ($omsg eq 'not found') {
|
||
|
|
$trash = join( $pathsep, $dataroot, "config.$SESSION{'clid'}");
|
||
|
|
$omsg = "";
|
||
|
|
open( CFGFILE, ">$trash" ) or $omsg="not found";
|
||
|
|
}
|
||
|
|
if ($omsg ne 'not found') {
|
||
|
|
for (0 .. $#cfgentries) {
|
||
|
|
print CFGFILE "$cfgentries[$_]\n";
|
||
|
|
}
|
||
|
|
close CFGFILE;
|
||
|
|
}
|
||
|
|
$chmodok = chmod 0666, $trash;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub createtrace {
|
||
|
|
my $trash = join( $pathsep, $secroot, "$ENV{'REMOTE_ADDR'}.log");
|
||
|
|
my $msg = "";
|
||
|
|
open( TRACEFILE, "<$trash") or $msg = "notfound";
|
||
|
|
if ($msg eq 'notfound') {
|
||
|
|
open( TRACEFILE, ">$trash" ) || return 0;
|
||
|
|
my $starttime= &format_date_time("yyyy-mm-dd hh:nn:ss GMT", "1", "0");
|
||
|
|
print TRACEFILE "$starttime\n";
|
||
|
|
close TRACEFILE;
|
||
|
|
my $chmodok = chmod 0666, $trash;
|
||
|
|
} else {
|
||
|
|
close TRACEFILE;
|
||
|
|
}
|
||
|
|
&opentrace();
|
||
|
|
}
|
||
|
|
|
||
|
|
sub traceoutput {
|
||
|
|
if ($SYSTEM{'traceon'} != 1) {
|
||
|
|
if (&opentrace()) {
|
||
|
|
&createtrace();
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($SYSTEM{'traceon'} == 1) {
|
||
|
|
print TRACEFILE "$_[0]\n";
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
sub opentrace {
|
||
|
|
my $trash = join( $pathsep, $secroot, "$ENV{'REMOTE_ADDR'}.log");
|
||
|
|
open( TRACEFILE, ">>$trash" ) || return 0;
|
||
|
|
$SYSTEM{'traceon'} = 1;
|
||
|
|
my $starttime= &format_date_time("yyyy-mm-dd hh:nn:ss GMT", "1", "0");
|
||
|
|
&traceoutput($starttime);
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub closetrace {
|
||
|
|
$SYSTEM{'traceon'} = 0;
|
||
|
|
my $starttime= &format_date_time("yyyy-mm-dd hh:nn:ss GMT", "1", "0");
|
||
|
|
&traceoutput($starttime);
|
||
|
|
close TRACEFILE;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub createdebug {
|
||
|
|
$trash = join( $pathsep, $secroot, "debug.$SESSION{'clid'}.txt");
|
||
|
|
$msg = "";
|
||
|
|
open( DBGFILE, "<$trash") or $msg = "notfound";
|
||
|
|
if ($msg eq 'notfound') {
|
||
|
|
open( DBGFILE, ">$trash" ) || return 0;
|
||
|
|
$starttime= &format_date_time("yyyy-mm-dd hh:nn:ss GMT", "1", "0");
|
||
|
|
&dbgprint("$starttime\n");
|
||
|
|
close DBGFILE;
|
||
|
|
$chmodok = chmod 0666, $trash;
|
||
|
|
} else {
|
||
|
|
close DBGFILE;
|
||
|
|
}
|
||
|
|
&opendebug("debug.txt");
|
||
|
|
}
|
||
|
|
|
||
|
|
sub opendebug {
|
||
|
|
$trash = join( $pathsep, $secroot, "debug.$SESSION{'clid'}.txt");
|
||
|
|
open( DBGFILE, ">>$trash" ) || return 0;
|
||
|
|
$debugon = 1;
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub dbgprint {
|
||
|
|
my ($s) = @_;
|
||
|
|
&opendebug();
|
||
|
|
print DBGFILE "$SESSION{'tid'}:$SESSION{'uid'}:$s";
|
||
|
|
&closedebug();
|
||
|
|
}
|
||
|
|
|
||
|
|
sub closedebug {
|
||
|
|
$debugon = 0;
|
||
|
|
close DBGFILE;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub showenv {
|
||
|
|
for (keys %ENV) {
|
||
|
|
if ($debugon) {
|
||
|
|
&dbgprint("$_ = $ENV{$_}\n");
|
||
|
|
} else {
|
||
|
|
print "<!-- $_ = $ENV{$_} -->\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$reqmeth = $ENV{'REQUEST_METHOD'};
|
||
|
|
if ($reqmeth =~ /POST/i) {
|
||
|
|
read (STDIN, $qstr, $ENV{'CONTENT_LENGTH'});
|
||
|
|
if ($debugon) {
|
||
|
|
&dbgprint("POSTED = $qstr\n");
|
||
|
|
} else {
|
||
|
|
print "<!-- POSTED = $qstr -->\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub show_message_with_close {
|
||
|
|
print "
|
||
|
|
<HTML>
|
||
|
|
<BODY>
|
||
|
|
<CENTER>
|
||
|
|
$_[0]<BR>
|
||
|
|
\ <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));
|
||
|
|
|
||
|
|
# parse request parameters into variables
|
||
|
|
$query = new CGI;
|
||
|
|
%FORM = $query->Vars;
|
||
|
|
|
||
|
|
#foreach $key (keys(%FORM)) {
|
||
|
|
#if ($FORM{$key} =~ /\-\-$/) {
|
||
|
|
#chop($FORM{$key});
|
||
|
|
#chop($FORM{$key});
|
||
|
|
#}
|
||
|
|
#}
|
||
|
|
|
||
|
|
### DED Rip ALL this out, change UPLOADED_FILES references
|
||
|
|
### to use "CGI::upload"
|
||
|
|
|
||
|
|
#if ($ftype eq 'csv') {
|
||
|
|
#$content =~ s/\r//g;
|
||
|
|
#$content =~ s/\n\n/\n/g;
|
||
|
|
#} else {
|
||
|
|
#### DED 1/24/06
|
||
|
|
## Removed for png supt
|
||
|
|
## but breaks reports
|
||
|
|
##$content =~ s/(.*)\r\n/$1/;
|
||
|
|
#$content =~ s/(.*)\r\n/$1/;
|
||
|
|
#}
|
||
|
|
|
||
|
|
# make sure connection is https
|
||
|
|
$set_https = 0;
|
||
|
|
if ($FORM{'clid'} ne '') {
|
||
|
|
&get_client_configuration($FORM{'clid'});
|
||
|
|
$set_https = 1;
|
||
|
|
} elsif ($FORM{'tid'} ne '' && &get_session($FORM{'tid'})) {
|
||
|
|
&get_client_configuration($SESSION{'clid'});
|
||
|
|
$set_https = 1;
|
||
|
|
}
|
||
|
|
if ($set_https) {
|
||
|
|
if ( ($ENV{'HTTPS'} ne "on") && ( ($SYSTEM{'FORCEHTTPSOVERRIDE'} eq "Yes") || ($SYSTEM{'FORCEHTTPSOVERRIDE'} ne "No" && $SYSTEM{'forcehttps'}) ) ) {
|
||
|
|
$url = "https://".$ENV{'SERVER_NAME'};
|
||
|
|
if ($ENV{'SERVER_PORT'} != "80") {
|
||
|
|
$port = $ENV{'SERVER_PORT'} + 1;
|
||
|
|
$url .= ":".$port;
|
||
|
|
}
|
||
|
|
$url .= $ENV{'REQUEST_URI'};
|
||
|
|
print "Location: $url\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($qstr) {
|
||
|
|
return 1;
|
||
|
|
} else {
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
sub copy_file {
|
||
|
|
system("cp $_[1] $_[0] -p");
|
||
|
|
print "<br>File successfully copied...<br>";
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
sub make_file {
|
||
|
|
if ( ! open (TMPFILE, "<$_[1]") ) {
|
||
|
|
&logger::logerr("Unable to open $_[1] for reading: $!\n");
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
@copylines = <TMPFILE>;
|
||
|
|
close TMPFILE;
|
||
|
|
if ( ! open (TMPFILE, ">$_[0]") ) {
|
||
|
|
&logger::logerr("Unable to open $_[0] for writing: $!\n");
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
if ($_[2] == 1) {
|
||
|
|
print TMPFILE "$copylines[0]";
|
||
|
|
} else {
|
||
|
|
foreach $copyline (@copylines) {
|
||
|
|
print TMPFILE "$copyline";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
close TMPFILE;
|
||
|
|
$chmodok = chmod 0666, $_[0];
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_io_file {
|
||
|
|
if ( ! open (TMPFILE, "<$_[0]") ) {
|
||
|
|
&logger::logerr("Unable to open $_[0] for reading: $!\n");
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
@copylines = <TMPFILE>;
|
||
|
|
close TMPFILE;
|
||
|
|
if ( ! open (TMPFILE, ">$_[1]") ) {
|
||
|
|
&logger::logerr("Unable to open $_[1] for writing: $!\n");
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
foreach $copyline (@copylines) {
|
||
|
|
print TMPFILE "$copyline";
|
||
|
|
}
|
||
|
|
close TMPFILE;
|
||
|
|
$chmodok = chmod 0666, $_[1];
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
############################################################################
|
||
|
|
#
|
||
|
|
# Function: cpbin( $fromfile, $tofile, $opts )
|
||
|
|
#
|
||
|
|
# Description: Perform a binary copy of one binary file to another.
|
||
|
|
#
|
||
|
|
# Usage: cpbin( $fromfile, $tofile, $opts )
|
||
|
|
#
|
||
|
|
# $opts is a hashref of options as follows:
|
||
|
|
#
|
||
|
|
# $opts->{clobber} : If set to 1, any existing $tofile will be clobbered.
|
||
|
|
# Otherwise, the copy will fail and return 0.
|
||
|
|
#
|
||
|
|
# Returns: 1 if successful, 0 if not, with very little error-checking
|
||
|
|
# to prevent accidental clobbering.
|
||
|
|
#
|
||
|
|
# Author: efl, 11/2001
|
||
|
|
#
|
||
|
|
############################################################################
|
||
|
|
sub cpbin {
|
||
|
|
my($fromfile, $tofile, $opts) = @_;
|
||
|
|
|
||
|
|
my $clobber = $opts->{clobber};
|
||
|
|
|
||
|
|
if ( -f $tofile && ! $clobber ) {
|
||
|
|
&logger::logerr("Unable to open $fromfile for writing: File exists and no clobbering allowed. Set \$opts->{clobber} = 1 to force clobbering.\n");
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( ! open (INFILE, "<$fromfile") ) {
|
||
|
|
&logger::logerr("Unable to open $fromfile for reading: $!\n");
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
binmode(INFILE);
|
||
|
|
@content = <INFILE>;
|
||
|
|
close INFILE;
|
||
|
|
|
||
|
|
if ( ! open (OUTFILE, ">$tofile") ) {
|
||
|
|
&logger::logerr("Unable to open $tofile for writing: $!\n");
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
binmode(OUTFILE);
|
||
|
|
foreach $content (@content) {
|
||
|
|
print OUTFILE $content;
|
||
|
|
}
|
||
|
|
close OUTFILE;
|
||
|
|
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub gentid {
|
||
|
|
$coreid = time;
|
||
|
|
$spfmt = join('', "\%s\%0", sprintf("%d", length($idmax)), "d");
|
||
|
|
$tid = sprintf( $spfmt, $coreid, (int(rand(0) * $idmax)));
|
||
|
|
return $tid;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub init_session {
|
||
|
|
if ($FORM{'clid'} eq 'sacc') { $FORM{'clid'} = 'std';}
|
||
|
|
$SESSION{'tid'} = &gentid;
|
||
|
|
$SESSION{'clid'}=$FORM{'clid'};
|
||
|
|
$SESSION{'uid'}=$FORM{'uid'};
|
||
|
|
$SESSION{'uac'}=$FORM{'uac'};
|
||
|
|
$SESSION{'useragent'}=$ENV{'HTTP_USER_AGENT'};
|
||
|
|
$SESSION{'ipaddr'}=$ENV{'REMOTE_ADDR'};
|
||
|
|
$SESSION{'referer'}=$ENV{'HTTP_REFERER'};
|
||
|
|
$SESSION{'home'}=$FORM{'home'};
|
||
|
|
$SESSION{'lang'}=$FORM{'lang'};
|
||
|
|
$SESSION{'loggedin'}=time;
|
||
|
|
if ($FORM{'browser'} eq '') {
|
||
|
|
if ($SESSION{'useragent'} =~ /MSIE/ ) {
|
||
|
|
$FORM{'browser'} = "MSIE/4";
|
||
|
|
} else {
|
||
|
|
$FORM{'browser'} = "NSNV/4";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
($SESSION{'browserapp'}, $SESSION{'browserversion'}) = split(/\//, $FORM{'browser'});
|
||
|
|
&put_session($SESSION{'tid'}, "y");
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_session {
|
||
|
|
my ($session_id, $skip_warning) = @_;
|
||
|
|
if (! defined $session_id) {
|
||
|
|
warn "HBI Undefined Session id" ;
|
||
|
|
}
|
||
|
|
if ($session_id eq "") {
|
||
|
|
&show_illegal_access_warning unless ($skip_warning);
|
||
|
|
warn "HBI Blank Session id" ;
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
unless ($session_id =~ m/^\d{13,15}$/ ) {
|
||
|
|
# only 13, 14, or 15 digits is OK.
|
||
|
|
warn "HBI Bad Session id $session_id ." ;
|
||
|
|
}
|
||
|
|
$trash = join($pathsep, $logroot, "sess.$session_id");
|
||
|
|
open (SESSFILE, "<$trash");
|
||
|
|
@sessrecs = <SESSFILE>;
|
||
|
|
close SESSFILE;
|
||
|
|
if ($#sessrecs == -1) {
|
||
|
|
&show_illegal_access_warning unless ($skip_warning);
|
||
|
|
warn "HBI No Lines in Session file." ;
|
||
|
|
return 0;
|
||
|
|
} else {
|
||
|
|
foreach $sessrec (@sessrecs) {
|
||
|
|
chop ($sessrec);
|
||
|
|
($nm,$vlu)=split(/=/,$sessrec);
|
||
|
|
$SESSION{$nm} = $vlu;
|
||
|
|
}
|
||
|
|
unless ($SESSION{'clid'}) {
|
||
|
|
warn "HBI Unknown Client ID in Session file." ;
|
||
|
|
}
|
||
|
|
unless ($SESSION{'uid'}) {
|
||
|
|
warn "HBI Unknown Candidate ID in Session file." ;
|
||
|
|
}
|
||
|
|
if ($SESSION{'clid'} eq 'sacc') { $SESSION{'clid'} = 'std';}
|
||
|
|
# FIXME: AOL's use of dynamically changing IP addresses on each
|
||
|
|
# FIXME: successive pageview breaks fails against this scheme.
|
||
|
|
# DED 2005-11-08 Removed to facilitate round-robin proxies
|
||
|
|
#$sameuser = ($SESSION{'ipaddr'} eq $ENV{'REMOTE_ADDR'}) ? 1 : 0;
|
||
|
|
#if ( $SESSION{'ipaddr'} ne $ENV{'REMOTE_ADDR'} ) {
|
||
|
|
# &logger::logwarn("SESSION{'ipaddr'} ($SESSION{'ipaddr'}) !== ENV{'REMOTE_ADDR'} ($ENV{'REMOTE_ADDR'}) for session ID $session_id");
|
||
|
|
#}
|
||
|
|
#$sameuser = ($SESSION{'loggedout'} ne '') ? 0 : $sameuser;
|
||
|
|
$sameuser = ($SESSION{'loggedout'} ne '') ? 0 : 1;
|
||
|
|
if ( $SESSION{'loggedout'} ne '' ) {
|
||
|
|
&logger::logwarn("SESSION{'loggedout'} ($SESSION{'loggedout'}) !== '' for session ID $session_id ... meaning exactly what??");
|
||
|
|
}
|
||
|
|
return $sameuser;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub close_session {
|
||
|
|
$SESSION{'loggedout'}=time;
|
||
|
|
&put_session($SESSION{'tid'});
|
||
|
|
$tofile = join($pathsep, $logroot, "sess.$_[0]");
|
||
|
|
$archivefile = join($pathsep, $logroot, "sess.$_[0]");
|
||
|
|
rename $tofile, $archivefile;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub set_session {
|
||
|
|
my $temp = $_[2];
|
||
|
|
&get_session($_[0]);
|
||
|
|
$SESSION{$_[1]} = $temp;
|
||
|
|
&put_session($_[0]);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub put_session {
|
||
|
|
if ($_[0] eq "") {
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
$SESSION{'lastaccess'}=time;
|
||
|
|
$trash = join($pathsep, $logroot, "sess.$_[0]");
|
||
|
|
open (SESSFILE, ">$trash");
|
||
|
|
for (keys %SESSION) {
|
||
|
|
print SESSFILE "$_\=$SESSION{$_}\n";
|
||
|
|
}
|
||
|
|
close SESSFILE;
|
||
|
|
if ($_[1] eq 'y') { $chmodok = chmod 0666, $trash;}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub show_illegal_access_warning {
|
||
|
|
my ($user) = @_;
|
||
|
|
&send_illegal_attempt;
|
||
|
|
print "<HTML>\n";
|
||
|
|
print "<BODY>\n";
|
||
|
|
print "\ <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;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($xltline =~ /(<%=)ESCAPED_(\S+\..*?%>)/i ) {
|
||
|
|
#
|
||
|
|
# I needed a way to indicate from within a template that a value
|
||
|
|
# needs to be escaped for use within an HTML tag. Thus,
|
||
|
|
# you may put "ESCAPED_" in front of any template tag
|
||
|
|
# and it gets removed here, but turns on the escape flag
|
||
|
|
# for a recursive call to xlatline() and escape_special_chars().
|
||
|
|
#
|
||
|
|
# Initially this is only being implemented for %QUESTION,
|
||
|
|
# but is structured to allow calls to escape_special_chars()
|
||
|
|
# for other template tag types (see example above). -efl, 2/2002
|
||
|
|
#
|
||
|
|
$xltline =~ s/(<%=)ESCAPED_(\S+\..*?%>)/$1$2/g;
|
||
|
|
return &xlatline($xltline, $fh, 1);
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($xltline =~ /<%=CANDIDATES\.Options%>/i ) {
|
||
|
|
&print_client_cnd_options($SESSION{'clid'}, $fh);
|
||
|
|
return "";
|
||
|
|
}
|
||
|
|
if ($xltline =~ /<%=CANDIDATE\.(.*?)%>/i ) {
|
||
|
|
# for (keys %CANDIDATE) # This is the original code. It is a loop. HBI
|
||
|
|
for (keys %CANDIDATE) {
|
||
|
|
$srch1 = "<%=CANDIDATE.authtestsoptions%>";
|
||
|
|
if ($xltline =~ m/$srch1/ ) {
|
||
|
|
if ($CANDIDATE{'inproglist'} eq '') {
|
||
|
|
@authtests = split(/\;/, $CANDIDATE{'authlist'});
|
||
|
|
my $repl = "";
|
||
|
|
foreach $authtest (@authtests) {
|
||
|
|
if ($FORM{'testid'} eq "" || $FORM{'testid'} eq "$authtest") {
|
||
|
|
&get_test_profile($SESSION{'clid'}, $authtest);
|
||
|
|
#print $fh "<OPTION value=\"$TEST{'pwdtag'}$TEST{'id'}\">$TEST{'desc'}\n";
|
||
|
|
$repl .= "<OPTION value=\"$TEST{'pwdtag'}$TEST{'popuptag'}$TEST{'id'}\">$TEST{'desc'}\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
#return "";
|
||
|
|
$xltline =~ s/$srch1/$repl/eg;
|
||
|
|
} else {
|
||
|
|
@authtests = split(/\;/, $CANDIDATE{'inproglist'});
|
||
|
|
my $repl = "";
|
||
|
|
foreach $authtest (@authtests) {
|
||
|
|
&get_test_profile($SESSION{'clid'}, $authtest);
|
||
|
|
#print "<OPTION value=\"$TEST{'pwdtag'}$TEST{'id'}\">$TEST{'desc'}\n";
|
||
|
|
$repl .= "<OPTION value=\"$TEST{'pwdtag'}$TEST{'popuptag'}$TEST{'id'}\">$TEST{'desc'}\n";
|
||
|
|
}
|
||
|
|
#return "";
|
||
|
|
$xltline =~ s/$srch1/$repl/eg;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$srch1 = "<%=CANDIDATE.authtestslist%>";
|
||
|
|
if ($xltline =~ m/$srch1/ ) {
|
||
|
|
$repl = $CANDIDATE{'authlist'};
|
||
|
|
$replinprog = "";
|
||
|
|
$replinprog = $CANDIDATE{'inproglist'};
|
||
|
|
if ($replinprog ne "") {
|
||
|
|
$replinprog=join('', $replinprog, '*');
|
||
|
|
if ($repl eq "") {
|
||
|
|
$repl=$replinprog;
|
||
|
|
} else {
|
||
|
|
$repl = join(';', $repl, $replinprog);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$xltline =~ s/$srch1/$repl/eg;
|
||
|
|
}
|
||
|
|
$srch1 = "<%=CANDIDATE.oldtestsoptions%>";
|
||
|
|
if ($xltline =~ m/$srch1/ ) {
|
||
|
|
@authtests = split(/\;/, $CANDIDATE{'completedlist'});
|
||
|
|
my $repl = "";
|
||
|
|
foreach $authtest (@authtests) {
|
||
|
|
&get_test_profile($SESSION{'clid'}, $authtest);
|
||
|
|
$repl .= "<OPTION value=\"$TEST{'emlcndrvwopt'}$TEST{'id'}\">$TEST{'desc'}\n";
|
||
|
|
}
|
||
|
|
$xltline =~ s/$srch1/$repl/g;
|
||
|
|
}
|
||
|
|
$srch1 = "<%=CANDIDATE.oldtestslist%>";
|
||
|
|
if ($xltline =~ m/$srch1/ ) {
|
||
|
|
$repl = $CANDIDATE{'completedlist'};
|
||
|
|
$xltline =~ s/$srch1/$repl/g;
|
||
|
|
}
|
||
|
|
$srch1 = "<%=CANDIDATE.groups%>";
|
||
|
|
if ($xltline =~ m/$srch1/ ) {
|
||
|
|
&print_owned_groups($CLIENT{'clid'}, $CANDIDATE{'cndid'}, $fh);
|
||
|
|
} else {
|
||
|
|
$repl = $CANDIDATE{$_};
|
||
|
|
$srch1 = join('', "<%=CANDIDATE.", $_, "%>");
|
||
|
|
$xltline =~ s/$srch1/$repl/g;
|
||
|
|
}
|
||
|
|
# v sac support for self-registration
|
||
|
|
$srch1 = "<%=CANDIDATE.selfregistertests%>";
|
||
|
|
if ($xltline =~ m/$srch1/ ) {
|
||
|
|
if ($CANDIDATE{'inproglist'} ne '') {
|
||
|
|
@authtests = split(/\;/, $CANDIDATE{'inproglist'});
|
||
|
|
foreach $authtest (@authtests) {
|
||
|
|
&get_test_profile($SESSION{'clid'}, $authtest);
|
||
|
|
print "<OPTION value=\"$TEST{'pwdtag'}$TEST{'popuptag'}$TEST{'id'}\">$TEST{'desc'}";
|
||
|
|
}
|
||
|
|
return "";
|
||
|
|
} else {
|
||
|
|
$repl=&get_selfreg_test_list($SESSION{'clid'}, $CANDIDATE{'completedlist'});
|
||
|
|
$xltline =~ s/$srch1/$repl/g;
|
||
|
|
$xltline =~ s/\n/<\/option>\n/g;
|
||
|
|
$xltline =~ s/\n<\/option>\n/\n/g;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# ^ sac support for self-registration
|
||
|
|
}
|
||
|
|
$srch1 = "<%=DATE%>";
|
||
|
|
if ($xltline =~ m/$srch1/ ) {
|
||
|
|
$repl = &format_date_time("dd-mmm-yyyy", 1, "0");
|
||
|
|
$xltline =~ s/$srch1/$repl/g;
|
||
|
|
}
|
||
|
|
if (!($xltline =~ /(<%=)NOP_(\S+.*?%>)/i)) {
|
||
|
|
$xltline =~ s/<%=(.*?)%>//g;
|
||
|
|
}
|
||
|
|
print $fh "$xltline";
|
||
|
|
} else {
|
||
|
|
print $fh "$xltline";
|
||
|
|
}
|
||
|
|
return $xltline;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_template {
|
||
|
|
my ($template_base) = @_;
|
||
|
|
warn "Template $template_base Used." ; # HBI Trace template usage.
|
||
|
|
# v sac check for custom template
|
||
|
|
if ($SESSION{'clid'} ne '') {
|
||
|
|
$tmpfile = join($pathsep, $resptmplt, "$SESSION{'clid'}","$template_base.htt");
|
||
|
|
} elsif ($FORM{'clid'} ne '') {
|
||
|
|
$tmpfile = join($pathsep, $resptmplt, "$FORM{'clid'}","$template_base.htt");
|
||
|
|
} else {
|
||
|
|
$tmpfile = join($pathsep, $resptmplt, "$CLIENT{'clid'}","$template_base.htt");
|
||
|
|
}
|
||
|
|
# ^ sac check for custom template
|
||
|
|
unless (&file_exists($tmpfile)) {
|
||
|
|
$tmpfile = join($pathsep, $resptmplt, "$template_base.htt");
|
||
|
|
}
|
||
|
|
# &logger::logdbg("Reading template $template_base.htt");
|
||
|
|
my @locallines;
|
||
|
|
# FIXME: This should probably just be done with get_data(). -efl
|
||
|
|
if ( open (TMPFILE, "<$tmpfile") ) {
|
||
|
|
@locallines = <TMPFILE>;
|
||
|
|
close TMPFILE;
|
||
|
|
} else {
|
||
|
|
&logger::logerr("Unable to open $tmpfile for reading: $!");
|
||
|
|
}
|
||
|
|
return @locallines;
|
||
|
|
}
|
||
|
|
|
||
|
|
############################################################################
|
||
|
|
#
|
||
|
|
# Function: generate_from_template($template_base, $targetfile)
|
||
|
|
#
|
||
|
|
# Description: Read and parse template with name $template_base.htt
|
||
|
|
# and output result to $targetfile.
|
||
|
|
#
|
||
|
|
# Returns: 1 if successful, 0 if not, with very little error-checking
|
||
|
|
# to prevent accidental clobbering.
|
||
|
|
#
|
||
|
|
# Author: efl, 11/2001
|
||
|
|
#
|
||
|
|
############################################################################
|
||
|
|
sub generate_from_template( $ $ ) {
|
||
|
|
my ($template_base, $targetfile) = @_;
|
||
|
|
if ( ! $template_base ) {
|
||
|
|
&logger::logerr("Unexpectedly undefined template basename; aborting template generation process.");
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
if ( ! $targetfile ) {
|
||
|
|
&logger::logerr("Unexpectedly undefined template target filename; aborting template generation process.");
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
if ( ! open (OUTFILE, ">$targetfile") ) {
|
||
|
|
&logger::logerr("Unable to open template target file '$targetfile': $!");
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
@lines = &get_template($template_base);
|
||
|
|
foreach $line (@lines) {
|
||
|
|
$line = &xlatline($line, *OUTFILE);
|
||
|
|
}
|
||
|
|
close OUTFILE;
|
||
|
|
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub show_template {
|
||
|
|
my ($base, $fh) = @_;
|
||
|
|
$fh = (defined($fh) ? $fh : *STDOUT);
|
||
|
|
if (defined($SESSION{'lang'})) {
|
||
|
|
&LoadLanguage($SESSION{'lang'});
|
||
|
|
} elsif (defined($FORM{'lang'})) {
|
||
|
|
&LoadLanguage($FORM{'lang'});
|
||
|
|
}
|
||
|
|
@lines = &get_template($base);
|
||
|
|
foreach $line (@lines) {
|
||
|
|
$line = &xlatline($line, $fh);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub show_admin_request {
|
||
|
|
my ($key) = @_;
|
||
|
|
&get_template($key);
|
||
|
|
@lines = &get_template($key);
|
||
|
|
foreach $line (@lines) {
|
||
|
|
$line = &xlatline($line);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
sub get_site_reports_list {
|
||
|
|
my ($fh) = @_;
|
||
|
|
$fh = (defined($fh) ? $fh : *STDOUT);
|
||
|
|
@rrecs = &get_data("sitereports.dat");
|
||
|
|
$nrecs = $#rrecs;
|
||
|
|
for $i (1 .. $nrecs) {
|
||
|
|
@flds = split(/&/, $rrecs[$i++]);
|
||
|
|
print $fh "<OPTION value=\"$flds[0]\">$flds[1]\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_client_reports_list {
|
||
|
|
my ($fh, $cndid, $uid) = @_;
|
||
|
|
$fh = (defined($fh) ? $fh : *STDOUT);
|
||
|
|
my $isaregistrar = &get_a_key("cnd.$cndid", $uid, "registrar");
|
||
|
|
@rrecs = &get_data("reports.$SESSION{'clid'}");
|
||
|
|
$nrecs = $#rrecs;
|
||
|
|
for $i (1 .. $nrecs) {
|
||
|
|
@flds = split(/&/, $rrecs[$i++]);
|
||
|
|
if ($isaregistrar eq 'Y') {
|
||
|
|
if ($flds[0] ne "ENV" && $flds[0] ne "GROUPS") {
|
||
|
|
print $fh "<OPTION value=\"$flds[0]\">$flds[1]\n";
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
print $fh "<OPTION value=\"$flds[0]\">$flds[1]\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
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;
|
||
|
|
if ( open (TMPFILE, "<$tmpfile") ) {
|
||
|
|
@locallines = <TMPFILE>;
|
||
|
|
close TMPFILE;
|
||
|
|
} else {
|
||
|
|
&logger::logerr("Unable to open $tmpfile for reading: $!");
|
||
|
|
}
|
||
|
|
return @locallines;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_log {
|
||
|
|
$tmpfile = join($pathsep, $logroot, $_[0]);
|
||
|
|
open (TMPFILE, "<$tmpfile") or $msg="failed";
|
||
|
|
@locallines = <TMPFILE>;
|
||
|
|
close TMPFILE;
|
||
|
|
return @locallines;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_madmin_client_list {
|
||
|
|
my ($clients, $fh) = @_;
|
||
|
|
$fh = (defined($fh) ? $fh : *STDOUT);
|
||
|
|
@clients = split(':', $clients);
|
||
|
|
for $i (0 .. $#clients) {
|
||
|
|
$clients[$i] =~ tr/\+/ /;
|
||
|
|
if ($clients[$i] eq $CLIENT{'clid'}) {
|
||
|
|
print $fh "<OPTION value=\"$clients[$i]\" selected>$clients[$i]</OPTION>\n";
|
||
|
|
} else {
|
||
|
|
print $fh "<OPTION value=\"$clients[$i]\">$clients[$i]</OPTION>\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub regdusr {
|
||
|
|
my ($template) = @_;
|
||
|
|
@lines = &get_template($template);
|
||
|
|
foreach $line (@lines) {
|
||
|
|
if ($line =~ /<%=SITE.REPORTS%>/) {
|
||
|
|
&get_site_reports_list;
|
||
|
|
} elsif ($line =~ /<%=CLIENT.REPORTS%>/) {
|
||
|
|
&get_client_reports_list(undef, $SESSION{'clid'}, $SESSION{'uid'});
|
||
|
|
} elsif ($line =~ /<%=MADMIN.CLIENTS%>/) {
|
||
|
|
&get_madmin_client_list($FORM{'clid'});
|
||
|
|
} elsif ($line =~ /<%=FORM.testid%>/) {
|
||
|
|
$line =~ s/<%=FORM.testid%>/$FORM{'testid'}/;
|
||
|
|
print $line;
|
||
|
|
} else {
|
||
|
|
$line = &xlatline($line);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub send_cookie {
|
||
|
|
$expdte = &format_date_time("dddd, dd-mmm-yy hh:nn:ss GMT", "1", "2592000");
|
||
|
|
print "Set-Cookie: $_[0]=$_[1]; DOMAIN=$ENV{'HTTP_HOST'}; path=/~smiadmin/; expires=$expdte\n";
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# $datetimestring = &format_date_time($formatstring,$timezone,$flag,$value)
|
||
|
|
# $formatstring dd = day
|
||
|
|
# mm = month (01,02,...)
|
||
|
|
# mmm = month (Jan,Feb,...)
|
||
|
|
# yy = year (00,01,...)
|
||
|
|
# yyyy = year (2000,2001,...)
|
||
|
|
# $timezone = 1 : GMT
|
||
|
|
# 2 : Local Time
|
||
|
|
# $flag = -1 : time - 1000
|
||
|
|
# -10000 : absolute ($value)
|
||
|
|
# ??? = relative (time + $flag)
|
||
|
|
#
|
||
|
|
sub format_date_time {
|
||
|
|
$sformatted = $_[0];
|
||
|
|
if ($_[1] == '1') {
|
||
|
|
if ($_[2]=='-1') {
|
||
|
|
@tmvalues = gmtime(time-1000);
|
||
|
|
} else {
|
||
|
|
if ($_[2]=='-10000') {
|
||
|
|
@tmvalues = gmtime($_[3]);
|
||
|
|
} else {
|
||
|
|
@tmvalues = gmtime(time+$_[2]);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
if ($_[2]=='-1') {
|
||
|
|
@tmvalues = localtime(time-1000);
|
||
|
|
} else {
|
||
|
|
if ($_[2]=='-10000') {
|
||
|
|
@tmvalues = localtime($_[3]);
|
||
|
|
} else {
|
||
|
|
@tmvalues = localtime(time+$_[2]);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
$ss = sprintf( "%02d", $tmvalues[0]);
|
||
|
|
($trash, $ms) = Time::HiRes::gettimeofday();
|
||
|
|
$nn = sprintf( "%02d", $tmvalues[1]);
|
||
|
|
$h = sprintf( "%d", $tmvalues[2]);
|
||
|
|
$hh = sprintf( "%02d", $tmvalues[2]);
|
||
|
|
$dd = sprintf( "%02d", $tmvalues[3]);
|
||
|
|
$mm = sprintf( "%02d", $tmvalues[4]+1);
|
||
|
|
$mmm = format_month($tmvalues[4], "0");
|
||
|
|
$mmmm = format_month($tmvalues[4], "1");
|
||
|
|
$yy = format_year($tmvalues[5], "0");
|
||
|
|
$yyyy = format_year($tmvalues[5], "1");
|
||
|
|
$ddd = format_day_of_week($tmvalues[6], "0");
|
||
|
|
$dddd = format_day_of_week($tmvalues[6], "1");
|
||
|
|
|
||
|
|
$sformatted =~ s/ss/$ss/ig;
|
||
|
|
$sformatted =~ s/ms/$ms/ig;
|
||
|
|
$sformatted =~ s/nn/$nn/ig;
|
||
|
|
$sformatted =~ s/hh/$hh/ig;
|
||
|
|
$sformatted =~ s/h/$h/ig;
|
||
|
|
$sformatted =~ s/dddd/$dddd/ig;
|
||
|
|
$sformatted =~ s/ddd/$ddd/ig;
|
||
|
|
$sformatted =~ s/dd/$dd/ig;
|
||
|
|
$sformatted =~ s/mmmm/$mmmm/ig;
|
||
|
|
$sformatted =~ s/mmm/$mmm/ig;
|
||
|
|
$sformatted =~ s/mm/$mm/ig;
|
||
|
|
$sformatted =~ s/yyyy/$yyyy/ig;
|
||
|
|
$sformatted =~ s/yy/$yy/ig;
|
||
|
|
return $sformatted;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub format_day_of_week {
|
||
|
|
@dayarray = ( ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"],
|
||
|
|
["Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday"] );
|
||
|
|
return $dayarray[$_[1]][$_[0]];
|
||
|
|
}
|
||
|
|
|
||
|
|
sub format_month {
|
||
|
|
@montharray = ( ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"],
|
||
|
|
["January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December"] );
|
||
|
|
return $montharray[$_[1]][$_[0]];
|
||
|
|
}
|
||
|
|
|
||
|
|
sub format_year {
|
||
|
|
if ($_[0] > '99') {
|
||
|
|
if ($_[1] == '0') {
|
||
|
|
return sprintf("%02d", $_[0]-100);
|
||
|
|
} else {
|
||
|
|
return sprintf("%04d", $_[0]+1900);
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
if ($_[1] == '0') {
|
||
|
|
return sprintf("%02d", $_[0]);
|
||
|
|
} else {
|
||
|
|
return sprintf("%04d", $_[0]+1900);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# returns date time values in array elements:
|
||
|
|
# 0 = seconds (0-59)
|
||
|
|
# 1 = minutes (0-59)
|
||
|
|
# 2 = hours (0-23)
|
||
|
|
# 3 = day (0-30)
|
||
|
|
# 4 = month (0-11)
|
||
|
|
# 5 = year
|
||
|
|
# 6 = day of week (0-6)
|
||
|
|
# 7 = seconds since Jan 1 1970
|
||
|
|
#
|
||
|
|
sub compute_date_time {
|
||
|
|
my ($datestring) = @_;
|
||
|
|
my @days = ('SUNDAY','MONDAY','TUESDAY','WEDNESDAY','THURSDAY','FRIDAY','SATURDAY');
|
||
|
|
my @months = ('JANUARY','FEBRUARY','MARCH','APRIL','MAY','JUNE','JULY','AUGUST','SEPTEMBER','OCTOBER','NOVEMBER','DECEMBER');
|
||
|
|
my @ampm = ('A','AM','P','PM');
|
||
|
|
my $pmflag=0;
|
||
|
|
my $tm="hns";
|
||
|
|
my $mm="mdy";
|
||
|
|
my @dtvalues=();
|
||
|
|
my @numvals=();
|
||
|
|
my @numflgs=();
|
||
|
|
my @chrs=split(//,$datestring);
|
||
|
|
my $c;
|
||
|
|
my $h="";
|
||
|
|
my $i=0;
|
||
|
|
my $j=0;
|
||
|
|
my $k=0;
|
||
|
|
my $l=0;
|
||
|
|
my $wordnum="";
|
||
|
|
my $wordstr="";
|
||
|
|
my $ignorespaces=1;
|
||
|
|
my $wordbreak=0;
|
||
|
|
foreach $c (@chrs) {
|
||
|
|
if (($c eq ' ') && ($ignorespaces)) {
|
||
|
|
next;
|
||
|
|
};
|
||
|
|
$ignorespaces=0;
|
||
|
|
if ($c =~ /([:\-\/\,\s])/ ) {
|
||
|
|
$wordbreak=1;
|
||
|
|
$ignorespaces=1;
|
||
|
|
} elsif ($c =~ /([a-zA-Z])/ ) {
|
||
|
|
if ($wordnum eq '') {
|
||
|
|
$wordstr=join('',$wordstr,"$c");
|
||
|
|
} else {
|
||
|
|
$wordbreak = 1;
|
||
|
|
$h=$c;
|
||
|
|
}
|
||
|
|
} elsif ($c =~ /([0-9])/ ) {
|
||
|
|
if ($wordstr eq '') {
|
||
|
|
$wordnum = join('',$wordnum,"$c");
|
||
|
|
} else {
|
||
|
|
$wordbreak = 1;
|
||
|
|
$h=$c;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
}
|
||
|
|
$wordbreak = ($c eq $chrs[$#chrs]) ? 1 : $wordbreak;
|
||
|
|
if ($wordbreak) {
|
||
|
|
$wordbreak=0;
|
||
|
|
if ($wordstr ne '') {
|
||
|
|
$wordstr = uc($wordstr);
|
||
|
|
# check AMPM and TZ
|
||
|
|
if (length($wordstr) < 3) {
|
||
|
|
for $j (0..$#ampm) {
|
||
|
|
if ($ampm[$j] eq $wordstr) {
|
||
|
|
$pmflag=($ampm[$j] =~ /P/ ) ? 1: 0;
|
||
|
|
for $k (0 .. $i) {
|
||
|
|
if ($numflgs[$k] eq 'h') {
|
||
|
|
if ($pmflag) {
|
||
|
|
if ($numvals[$k] < 12) {
|
||
|
|
$numvals[$k]+=12;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
if ($numvals[$k] > 11) {
|
||
|
|
$numvals[$k]-=12;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
# check TZ
|
||
|
|
# check for month
|
||
|
|
for $j (0..$#months) {
|
||
|
|
if ($months[$j] =~ /$wordstr/ ) {
|
||
|
|
$numvals[$i]=$j;
|
||
|
|
$numflgs[$i]="m";
|
||
|
|
$mm =~ s/m//;
|
||
|
|
$i++;
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$wordstr="";
|
||
|
|
} else {
|
||
|
|
if ($c eq ':') {
|
||
|
|
# time element
|
||
|
|
$numflgs[$i]=substr($tm,0,1);
|
||
|
|
$tm=substr($tm,1);
|
||
|
|
} elsif (($c eq '/') || ($c eq '-')) {
|
||
|
|
# date element
|
||
|
|
$numflgs[$i]=$mm;
|
||
|
|
} else {
|
||
|
|
$j=$i-1;
|
||
|
|
if ($numflgs[$j] eq 'n') {
|
||
|
|
$numflgs[$i]="s";
|
||
|
|
$tm = s/s//;
|
||
|
|
} else {
|
||
|
|
$numflgs[$i]="?";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$numvals[$i]=$wordnum;
|
||
|
|
$wordnum="";
|
||
|
|
$i++;
|
||
|
|
}
|
||
|
|
if ($h ne '') {
|
||
|
|
if ($h =~ /([a-zA-Z])/ ) {
|
||
|
|
$wordstr=$h;
|
||
|
|
} else {
|
||
|
|
$wordnum=$h;
|
||
|
|
}
|
||
|
|
$h="";
|
||
|
|
$wordbreak = ($c eq $chrs[$#chrs]) ? 1 : 0;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
for $j (0 .. $#numvals) {
|
||
|
|
$i = $j-1;
|
||
|
|
$k = $j+1;
|
||
|
|
if ($numflgs[$j] eq '?') {
|
||
|
|
if ($j == 0) {
|
||
|
|
if ($numflgs[$k] eq 'm') {
|
||
|
|
$numflgs[$j]="d";
|
||
|
|
$k++;
|
||
|
|
$numflgs[$k]="y";
|
||
|
|
}
|
||
|
|
} elsif ($j == 1) {
|
||
|
|
if ($numflgs[$i] eq 'm') {
|
||
|
|
$numflgs[$j]="d";
|
||
|
|
$numflgs[$k]="y";
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
if (($j == 2) && ($numflgs[$i] eq 'm')) {
|
||
|
|
$i--;
|
||
|
|
if ($numflgs[$i] eq 'mdy') {
|
||
|
|
$numflgs[$i]="d";
|
||
|
|
$i++;
|
||
|
|
}
|
||
|
|
$numflgs[$j]="y";
|
||
|
|
next;
|
||
|
|
}
|
||
|
|
if ($numflgs[$i] eq 'mdy') {
|
||
|
|
$i--;
|
||
|
|
if ($numflgs[$i] eq 'mdy') {
|
||
|
|
$numflgs[$i]="m";
|
||
|
|
$numvals[$i]--;
|
||
|
|
$i++;
|
||
|
|
$numflgs[$i]="d";
|
||
|
|
$numflgs[$j]="y";
|
||
|
|
}
|
||
|
|
} elsif ($numflgs[$i] eq 'h') {
|
||
|
|
$numflgs[$j]="n";
|
||
|
|
} elsif (length($numvals[$j]) >= 4) {
|
||
|
|
$k=length($numvals[$j]);
|
||
|
|
$l=$#numflgs+1;
|
||
|
|
for $i (0 .. $k) {
|
||
|
|
if ($i == 1) {
|
||
|
|
$numvals[$l]=substr($numvals[$j],0,2);
|
||
|
|
$numflgs[$l]="h";
|
||
|
|
$l++;
|
||
|
|
} elsif ($i == 3) {
|
||
|
|
$numvals[$l]=substr($numvals[$j],2,2);
|
||
|
|
$numflgs[$l]="n";
|
||
|
|
$l++;
|
||
|
|
} elsif ($i == 5) {
|
||
|
|
$numvals[$l]=substr($numvals[$j],4);
|
||
|
|
$numflgs[$l]="s";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$numvals[$j]="";
|
||
|
|
$numflgs[$j]="";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$dtvalues[0]=0;
|
||
|
|
$dtvalues[1]=0;
|
||
|
|
$dtvalues[2]=0;
|
||
|
|
$dtvalues[3]=0;
|
||
|
|
$dtvalues[4]=0;
|
||
|
|
$dtvalues[5]=0;
|
||
|
|
$dtvalues[6]=0;
|
||
|
|
$dtvalues[7]=0;
|
||
|
|
$j=0;
|
||
|
|
for $i (0..$#numvals) {
|
||
|
|
$dtvalue[$i]=0;
|
||
|
|
if ($numflgs[$i] eq 's') {
|
||
|
|
$dtvalues[0]=$numvals[$i];
|
||
|
|
$j+=int($numvals[$i]);
|
||
|
|
} elsif ($numflgs[$i] eq 'n') {
|
||
|
|
$dtvalues[1]=$numvals[$i];
|
||
|
|
$j+=(int($numvals[$i])*60);
|
||
|
|
} elsif ($numflgs[$i] eq 'h') {
|
||
|
|
$dtvalues[2]=$numvals[$i];
|
||
|
|
$j+=(int($numvals[$i])*3600);
|
||
|
|
} elsif ($numflgs[$i] eq 'd') {
|
||
|
|
$dtvalues[3]=$numvals[$i];
|
||
|
|
$j+=((int($numvals[$i])-1)*86400);
|
||
|
|
} elsif ($numflgs[$i] eq 'm') {
|
||
|
|
$dtvalues[4]=$numvals[$i];
|
||
|
|
} elsif ($numflgs[$i] eq 'y') {
|
||
|
|
if ($numvals[$i] < 100) {
|
||
|
|
if ($numvals[$i] > 69) {
|
||
|
|
$numvals[$i]+=1900;
|
||
|
|
} else {
|
||
|
|
$numvals[$i]+=2000;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$dtvalues[5]=$numvals[$i];
|
||
|
|
$k=int($numvals[$i])-1970;
|
||
|
|
$l=($k+2)-(($k+2) % 4);
|
||
|
|
$l=int($l/4) * 86400;
|
||
|
|
$j+=(($k*31536000)+$l);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$j+=compute_month_seconds($dtvalues[5],$dtvalues[4]);
|
||
|
|
$dtvalues[7]=$j;
|
||
|
|
return wantarray ? @dtvalues : $j;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub compute_month_seconds {
|
||
|
|
my ($y,$m) = @_;
|
||
|
|
my $i;
|
||
|
|
my $n=0;
|
||
|
|
my @dpm = (0,31,28,31,30,31,30,31,31,30,31,30);
|
||
|
|
$y %= 4;
|
||
|
|
if ($y==0) {
|
||
|
|
@dpm[2]++;
|
||
|
|
}
|
||
|
|
for $i (0 .. $m) {
|
||
|
|
$n+=$dpm[$i]*86400;
|
||
|
|
}
|
||
|
|
return $n;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub log_entry {
|
||
|
|
#
|
||
|
|
# Emergency fix for lost test data
|
||
|
|
#
|
||
|
|
# my ($clid, $uid) = @_;
|
||
|
|
# $tmstmp = &format_date_time("dd-mmm-yy hh:nn:ss GMT", "1", "0");
|
||
|
|
# @flds = @_;
|
||
|
|
# $j = $#flds;
|
||
|
|
# $newrec = $tmstmp;
|
||
|
|
# $newrec = join(',', $newrec, $SESSION{'tid'});
|
||
|
|
# for $i (2 .. $j) {
|
||
|
|
# $newrec = join(',', $newrec, $flds[$i++]);
|
||
|
|
# }
|
||
|
|
# $logfile = join($pathsep, $logroot, "$clid.$uid");
|
||
|
|
# if (open (TMPFILE, ">>$logfile")) {
|
||
|
|
# print TMPFILE "$newrec\n";
|
||
|
|
# close TMPFILE;
|
||
|
|
# } else {
|
||
|
|
# open (TMPFILE, ">$logfile");
|
||
|
|
# @tmprecs = <TMPFILE>;
|
||
|
|
# foreach $tmprec (@tmprecs) {
|
||
|
|
# print TMPFILE "$tmprec";
|
||
|
|
# }
|
||
|
|
# print TMPFILE "$newrec\n";
|
||
|
|
# close TMPFILE;
|
||
|
|
# }
|
||
|
|
# $chmodok = chmod 0666, $logfile;
|
||
|
|
my ($clid, $uid, $code, $message, $tmstmp) = @_;
|
||
|
|
my $i;
|
||
|
|
my $logfile;
|
||
|
|
my @tmprecs;
|
||
|
|
my $chmodok;
|
||
|
|
|
||
|
|
if (!$tmstmp) {
|
||
|
|
$tmstmp = &format_date_time("dd-mmm-yyyy hh:nn:ss.ms GMT", "1", "0");
|
||
|
|
}
|
||
|
|
my @flds = @_;
|
||
|
|
my $j = $#flds;
|
||
|
|
my $newrec = $tmstmp;
|
||
|
|
$newrec = join(',', $newrec, $SESSION{'tid'});
|
||
|
|
for $i (2 .. $j) {
|
||
|
|
$newrec = join(',', $newrec, $flds[$i++]);
|
||
|
|
}
|
||
|
|
$logfile = join($pathsep, $logroot, "$clid.$uid");
|
||
|
|
if (open (TMPFILE, ">>$logfile")) {
|
||
|
|
print TMPFILE "$newrec\n";
|
||
|
|
close TMPFILE;
|
||
|
|
} else {
|
||
|
|
open (TMPFILE, ">$logfile");
|
||
|
|
@tmprecs = <TMPFILE>;
|
||
|
|
foreach $tmprec (@tmprecs) {
|
||
|
|
print TMPFILE "$tmprec";
|
||
|
|
}
|
||
|
|
print TMPFILE "$newrec\n";
|
||
|
|
close TMPFILE;
|
||
|
|
}
|
||
|
|
$chmodok = chmod 0666, $logfile;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub print_client_adminids {
|
||
|
|
my ($filterid, $fh) = @_;
|
||
|
|
$fh = (defined($fh) ? $fh : *STDOUT);
|
||
|
|
@adminids = &get_data("admin.dat");
|
||
|
|
$adminid = $adminids[0];
|
||
|
|
chop($adminid);
|
||
|
|
@lstflds = split(/&/, $adminid);
|
||
|
|
$lstidx = 0;
|
||
|
|
foreach $lstfld (@lstflds) {
|
||
|
|
if ($lstfld eq 'uid') { $uididx = $lstidx;}
|
||
|
|
elsif ($lstfld eq 'clid') { $clididx = $lstidx;}
|
||
|
|
elsif ($lstfld eq 'uac') { $uacidx = $lstidx;}
|
||
|
|
$lstidx++;
|
||
|
|
}
|
||
|
|
for (1 .. $#adminids) {
|
||
|
|
$adminid = $adminids[$_];
|
||
|
|
chop($adminid);
|
||
|
|
@lstflds = split(/&/, $adminid);
|
||
|
|
if ($lstflds[$uacidx] eq "madmin") {
|
||
|
|
$ids{$lstflds[$uididx]} = "m-$lstflds[$clididx]";
|
||
|
|
} elsif ($lstflds[$clididx] eq $filterid ) {
|
||
|
|
$ids{$lstflds[$uididx]} = "$lstflds[$clididx]";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
foreach $lstid (keys(%ids)) {
|
||
|
|
print $fh "<OPTION VALUE=\"$ids{$lstid}\">$lstid</OPTION>\n";
|
||
|
|
}
|
||
|
|
@lstflds = ();
|
||
|
|
@adminids = ();
|
||
|
|
}
|
||
|
|
|
||
|
|
sub print_client_test_forms {
|
||
|
|
my ($clientID, $fh) = @_;
|
||
|
|
$fh = (defined($fh) ? $fh : *STDOUT);
|
||
|
|
$omsg = "";
|
||
|
|
opendir( DATADIR, $questionroot ) or $omsg="could not open dir $questionroot: $!";
|
||
|
|
if ($omsg ne "") {
|
||
|
|
# handle error message
|
||
|
|
#print $fh "$omsg\n";
|
||
|
|
} else {
|
||
|
|
@client_forms = grep { /$clientID.form$/ && -f "$questionroot/$_" } readdir(DATADIR);
|
||
|
|
closedir(DATADIR);
|
||
|
|
$numcforms = $#client_forms + 1;
|
||
|
|
$tests = "";
|
||
|
|
for ($i=0;$i<$numcforms;$i++) {
|
||
|
|
my ($test, $trash) = split(/\./, $client_forms[$i]);
|
||
|
|
$tests .= "\"$test\",";
|
||
|
|
}
|
||
|
|
$tests = substr($tests, 0, -1);
|
||
|
|
print $fh "\tvar forms = new Array($tests)";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub make_group {
|
||
|
|
$grpfile = join($pathsep, $dataroot, "$_[0].groups");
|
||
|
|
open (TMPGRP, "<$grpfile") or $mustcreate = 1;
|
||
|
|
close TMPGRP;
|
||
|
|
if ($mustcreate == 1) {
|
||
|
|
$grpfilestd = join($pathsep, $dataroot, "groups.std");
|
||
|
|
&make_file($grpfile, $grpfilestd, 1);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_group_owners {
|
||
|
|
@grpowners = &get_data("cnd.$_[0]");
|
||
|
|
$grpowner = shift @grpowners;
|
||
|
|
chop ($grpowner);
|
||
|
|
@grpflds = split(/&/, $grpowner);
|
||
|
|
for (1 .. $#grpflds) { $GOFIELDS{$grpflds[$_]} = $_; }
|
||
|
|
@grpflds = ();
|
||
|
|
return @grpowners;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub print_group_owners {
|
||
|
|
my ($clientID, $fh, $ownedby_flag) = @_;
|
||
|
|
$fh = (defined($fh) ? $fh : *STDOUT);
|
||
|
|
@grpowners = &get_group_owners($clientID);
|
||
|
|
$idxid = $GOFIELDS{'cndid'};
|
||
|
|
$idxnmf = $GOFIELDS{'nmf'};
|
||
|
|
$idxnmm = $GOFIELDS{'nmm'};
|
||
|
|
$idxnml = $GOFIELDS{'nml'};
|
||
|
|
$idxgrpo = $GOFIELDS{'grpowner'};
|
||
|
|
for (0 .. $#grpowners) {
|
||
|
|
$grpowner = $grpowners[$_];
|
||
|
|
chop ($grpowner);
|
||
|
|
@grpdata = split(/&/, $grpowner);
|
||
|
|
$selected = "";
|
||
|
|
if ($grpdata[$idxgrpo] eq 'Y') {
|
||
|
|
if ($ownedby_flag && $grpdata[$idxid] eq $TEST{'ownedby'}) {
|
||
|
|
$selected = " SELECTED";
|
||
|
|
}
|
||
|
|
print $fh "<OPTION VALUE=\"$grpdata[$idxid]\"$selected>$grpdata[$idxnml], $grpdata[$idxnmf] $grpdata[$idxnmm]</OPTION>\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_registrars {
|
||
|
|
@registrars = &get_data("cnd.$_[0]");
|
||
|
|
$registrar = shift @registrars;
|
||
|
|
chop ($registrar);
|
||
|
|
@regflds = split(/&/, $registrar);
|
||
|
|
for (1 .. $#regflds) { $REGFIELDS{$regflds[$_]} = $_; }
|
||
|
|
@regflds = ();
|
||
|
|
return @registrars;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub print_registrars {
|
||
|
|
my ($clientID, $fh, $ownedby_flag) = @_;
|
||
|
|
$fh = (defined($fh) ? $fh : *STDOUT);
|
||
|
|
@registrars = &get_registrars($clientID);
|
||
|
|
$idxid = $REGFIELDS{'cndid'};
|
||
|
|
$idxnmf = $REGFIELDS{'nmf'};
|
||
|
|
$idxnmm = $REGFIELDS{'nmm'};
|
||
|
|
$idxnml = $REGFIELDS{'nml'};
|
||
|
|
$idxreg = $REGFIELDS{'registrar'};
|
||
|
|
for (0 .. $#registrars) {
|
||
|
|
$registrar = $registrars[$_];
|
||
|
|
chop ($registrar);
|
||
|
|
@regdata = split(/&/, $registrar);
|
||
|
|
$selected = "";
|
||
|
|
if ($regdata[$idxreg] eq 'Y') {
|
||
|
|
if ($ownedby_flag && $regdata[$idxid] eq $TEST{'ownedby'}) {
|
||
|
|
$selected = " SELECTED";
|
||
|
|
}
|
||
|
|
print $fh "<OPTION VALUE=\"$regdata[$idxid]\"$selected>$regdata[$idxnml], $regdata[$idxnmf] $regdata[$idxnmm]</OPTION>\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_client_groups {
|
||
|
|
@grpsunsorted = &get_data( "groups.$_[0]");
|
||
|
|
$grp = shift @grpsunsorted;
|
||
|
|
@grps = sort @grpsunsorted;
|
||
|
|
@grpsunsorted = ();
|
||
|
|
chop ($grp);
|
||
|
|
@grpflds = split(/&/, $grp);
|
||
|
|
for (0 .. $#grpflds) { $GRPFIELD{$grpflds[$_]} = $_; }
|
||
|
|
@grpflds = ();
|
||
|
|
return @grps;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_group {
|
||
|
|
@grpcnds = &get_data("cnd.$_[0]");
|
||
|
|
$grpcnd = $grpcnds[0];
|
||
|
|
chop ($grpcnd);
|
||
|
|
$grpcndflds = split(/&/, $grpcnd);
|
||
|
|
for (0 .. $#grpcndflds) { $GRPMEMFLDS{$grpcndflds[$_]} = $_;}
|
||
|
|
@grpcndflds = ();
|
||
|
|
$idxgrpid = $GRPMEMFLDS{'grpid'};
|
||
|
|
$idxmemid = $GRPMEMFLDS{'cndid'};
|
||
|
|
$idxmemnme = "$GRPMEMFLDS{'nml'}, $GRPMEMFLDS{'nmf'}, $GRPMEMFLDS{'nmm'}";
|
||
|
|
for (1 .. $#grpcnds) {
|
||
|
|
$grpcnd = $grpcnds[$_];
|
||
|
|
chop ($grp);
|
||
|
|
@grpcnddata = split(/&/, $grpcnd);
|
||
|
|
if ($grpcnddata[$idxgrpid] =~ /$_[0].$_[1]/i ) {
|
||
|
|
|
||
|
|
} else {
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# DED 11/9/04
|
||
|
|
# send clid, grpid
|
||
|
|
# return array of cndids in group
|
||
|
|
sub get_group_cnds {
|
||
|
|
my @groups = &get_client_groups($_[0]);
|
||
|
|
my $grpid = $_[1];
|
||
|
|
foreach (@groups) {
|
||
|
|
my @grp = split(/\&/, $_);
|
||
|
|
if ($grp[1] eq "$grpid") {
|
||
|
|
my @cnds = split(/\,/,$grp[3]);
|
||
|
|
return @cnds;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_owned_groups {
|
||
|
|
@ownedgrps = ();
|
||
|
|
@grps = &get_client_groups($_[0]);
|
||
|
|
foreach $grp (@grps) {
|
||
|
|
if ($grp =~ /$_[0].$_[1].(\.\*)\&/i ) {
|
||
|
|
push @ownedgrps, $grp;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
@grps = ();
|
||
|
|
return @ownedgrps;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub print_client_groups {
|
||
|
|
my ($clientID, $fh) = @_;
|
||
|
|
$fh = (defined($fh) ? $fh : *STDOUT);
|
||
|
|
@cligrps = &get_client_groups($clientID);
|
||
|
|
$idxid = $GRPFIELD{'grpid'};
|
||
|
|
$idxdesc = $GRPFIELD{'grpdesc'};
|
||
|
|
for (0 .. $#cligrps) {
|
||
|
|
$grp = $cligrps[$_];
|
||
|
|
chop ($grp);
|
||
|
|
@grpdata = split(/&/, $grp);
|
||
|
|
print $fh "<OPTION VALUE=\"$grpdata[$idxid]\">$grpdata[$idxdesc]\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub print_owned_groups {
|
||
|
|
@cligrps = &get_owned_groups($_[0], $_[1]);
|
||
|
|
my $fh = (defined($_[2]) ? $_[2] : *STDOUT);
|
||
|
|
$idxid = $GRPFIELD{'grpid'};
|
||
|
|
$idxdesc = $GRPFIELD{'grpdesc'};
|
||
|
|
for (1 .. $#cligrps) {
|
||
|
|
$grp = $cligrps[$_];
|
||
|
|
chop ($grp);
|
||
|
|
@grpdata = split(/&/, $grp);
|
||
|
|
print $fh "<OPTION VALUE=\"$grpdata[$idxid]\">$grpdata[$idxdesc]\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
$SYSTEM{'years'} = "<OPTION VALUE=\"2002\">2002
|
||
|
|
<OPTION VALUE=\"2003\">2003
|
||
|
|
<OPTION VALUE=\"2004\">2004
|
||
|
|
<OPTION VALUE=\"2005\">2005
|
||
|
|
<OPTION VALUE=\"2006\">2006
|
||
|
|
<OPTION VALUE=\"2007\">2007
|
||
|
|
<OPTION VALUE=\"2008\">2008
|
||
|
|
<OPTION VALUE=\"2009\">2009
|
||
|
|
";
|
||
|
|
$SYSTEM{'months'} = "<OPTION VALUE=\"01\">Jan
|
||
|
|
<OPTION VALUE=\"02\">Feb
|
||
|
|
<OPTION VALUE=\"03\">Mar
|
||
|
|
<OPTION VALUE=\"04\">Apr
|
||
|
|
<OPTION VALUE=\"05\">May
|
||
|
|
<OPTION VALUE=\"06\">Jun
|
||
|
|
<OPTION VALUE=\"07\">Jul
|
||
|
|
<OPTION VALUE=\"08\">Aug
|
||
|
|
<OPTION VALUE=\"09\">Sep
|
||
|
|
<OPTION VALUE=\"10\">Oct
|
||
|
|
<OPTION VALUE=\"11\">Nov
|
||
|
|
<OPTION VALUE=\"12\">Dec
|
||
|
|
";
|
||
|
|
$SYSTEM{'days'} = "<OPTION VALUE=\"01\">01
|
||
|
|
<OPTION VALUE=\"02\">02
|
||
|
|
<OPTION VALUE=\"03\">03
|
||
|
|
<OPTION VALUE=\"04\">04
|
||
|
|
<OPTION VALUE=\"05\">05
|
||
|
|
<OPTION VALUE=\"06\">06
|
||
|
|
<OPTION VALUE=\"07\">07
|
||
|
|
<OPTION VALUE=\"08\">08
|
||
|
|
<OPTION VALUE=\"09\">09
|
||
|
|
<OPTION VALUE=\"10\">10
|
||
|
|
<OPTION VALUE=\"11\">11
|
||
|
|
<OPTION VALUE=\"12\">12
|
||
|
|
<OPTION VALUE=\"13\">13
|
||
|
|
<OPTION VALUE=\"14\">14
|
||
|
|
<OPTION VALUE=\"15\">15
|
||
|
|
<OPTION VALUE=\"16\">16
|
||
|
|
<OPTION VALUE=\"17\">17
|
||
|
|
<OPTION VALUE=\"18\">18
|
||
|
|
<OPTION VALUE=\"19\">19
|
||
|
|
<OPTION VALUE=\"20\">20
|
||
|
|
<OPTION VALUE=\"21\">21
|
||
|
|
<OPTION VALUE=\"22\">22
|
||
|
|
<OPTION VALUE=\"23\">23
|
||
|
|
<OPTION VALUE=\"24\">24
|
||
|
|
<OPTION VALUE=\"25\">25
|
||
|
|
<OPTION VALUE=\"26\">26
|
||
|
|
<OPTION VALUE=\"27\">27
|
||
|
|
<OPTION VALUE=\"28\">28
|
||
|
|
<OPTION VALUE=\"29\">29
|
||
|
|
<OPTION VALUE=\"30\">30
|
||
|
|
<OPTION VALUE=\"31\">31
|
||
|
|
";
|
||
|
|
|
||
|
|
$SYSTEM{'hours'} = "<OPTION VALUE=\"1\">1
|
||
|
|
<OPTION VALUE=\"2\">2
|
||
|
|
<OPTION VALUE=\"3\">3
|
||
|
|
<OPTION VALUE=\"4\">4
|
||
|
|
<OPTION VALUE=\"5\">5
|
||
|
|
<OPTION VALUE=\"6\">6
|
||
|
|
<OPTION VALUE=\"7\">7
|
||
|
|
<OPTION VALUE=\"8\">8
|
||
|
|
<OPTION VALUE=\"9\">9
|
||
|
|
<OPTION VALUE=\"10\">10
|
||
|
|
<OPTION VALUE=\"11\">11
|
||
|
|
<OPTION VALUE=\"12\">12
|
||
|
|
";
|
||
|
|
|
||
|
|
$SYSTEM{'minutes'} = "<OPTION VALUE=\"00\">00
|
||
|
|
<OPTION VALUE=\"5\">05
|
||
|
|
<OPTION VALUE=\"10\">10
|
||
|
|
<OPTION VALUE=\"15\">15
|
||
|
|
<OPTION VALUE=\"20\">20
|
||
|
|
<OPTION VALUE=\"25\">25
|
||
|
|
<OPTION VALUE=\"30\">30
|
||
|
|
<OPTION VALUE=\"35\">35
|
||
|
|
<OPTION VALUE=\"40\">40
|
||
|
|
<OPTION VALUE=\"45\">45
|
||
|
|
<OPTION VALUE=\"50\">50
|
||
|
|
<OPTION VALUE=\"55\">55
|
||
|
|
";
|
||
|
|
|
||
|
|
$SYSTEM{'pmoffset'} = "<OPTION VALUE=\"00\">AM
|
||
|
|
<OPTION VALUE=\"12\">PM
|
||
|
|
";
|
||
|
|
|
||
|
|
# <ACTSEMBED='filename' ALIGN=TOP|BOTTOM|INSERT NUMBER=BEFORE|AFTER>
|
||
|
|
sub merg_exhibit_in_text {
|
||
|
|
$beginKeep = 0;
|
||
|
|
$tmptext = $_[0];
|
||
|
|
$findtext = "<ACTSEMBED=(.*)>";
|
||
|
|
if ($tmptext =~ /$findtext/i ) {
|
||
|
|
$findtext = "<ACTS";
|
||
|
|
($toptext,$exhcmd) = split(/$findtext/, $tmptext);
|
||
|
|
($exhcmd,$bottomtext) = split(/>/, $exhcmd);
|
||
|
|
lc($exhcmd);
|
||
|
|
@parms = split(/ /, $exhcmd);
|
||
|
|
foreach $parm (@parms) {
|
||
|
|
$parm =~ s/ //g;
|
||
|
|
($nme,$vlu) = split(/=/, $parm);
|
||
|
|
if (($nme ne '') && ($vlu ne '')) {
|
||
|
|
lc($nme);
|
||
|
|
lc($vlu);
|
||
|
|
$EXHIBIT_PARM{$nme} = $vlu;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($EXHIBIT_PARM{'EMBED'} ne '') {
|
||
|
|
$prefile = join($pathsep, $questionroot, "actsexhibit", $EXHIBIT_PARM{'EMBED'});
|
||
|
|
$exhfile = &file_exists_with_extension($prefile, "htt;htm;html");
|
||
|
|
if ($exhfile ne '') {
|
||
|
|
open(EXHFILE, "<$exhfile");
|
||
|
|
@exhlines = <EXHFILE>;
|
||
|
|
close EXHFILE;
|
||
|
|
$instext = "\n";
|
||
|
|
foreach $exhline (@exhlines) {
|
||
|
|
if ($exhline =~ /<BODY/i) {
|
||
|
|
$beginKeep=1;
|
||
|
|
} else {
|
||
|
|
if ($beginKeep) {
|
||
|
|
if ($exhline =~ /BODY>/i) {
|
||
|
|
$beginKeep=0;
|
||
|
|
} else {
|
||
|
|
$instext = join('', $instext, $exhline);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($EXHIBIT_PATM{'align'} eq 'bottom') {
|
||
|
|
$tmptext = join('', $_[0], $instext);
|
||
|
|
} elsif ($EXHIBIT_PATM{'align'} eq 'insert') {
|
||
|
|
$tmptext = join('', $toptext, $instext, $bottomtext);
|
||
|
|
} else {
|
||
|
|
$tmptext = join('', $instext, $_[0]);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $tmptext;
|
||
|
|
}
|
||
|
|
|
||
|
|
# @phrases = &get_phrases(_LANGUAGE_ID);
|
||
|
|
sub get_phrases {
|
||
|
|
my ($lang) = @_;
|
||
|
|
$tmpfile = join($pathsep, $secroot, "language", "phrases.$lang");
|
||
|
|
if ( ! open (TMPFILE, "<$tmpfile") ) {
|
||
|
|
&logger::logerr("Unable to read $tmpfile: $!");
|
||
|
|
return ();
|
||
|
|
}
|
||
|
|
@locallines = <TMPFILE>;
|
||
|
|
close TMPFILE;
|
||
|
|
return @locallines;
|
||
|
|
}
|
||
|
|
|
||
|
|
# @phrases = &put_phrases($languageid);
|
||
|
|
sub put_phrases {
|
||
|
|
$tmpfile = join($pathsep, $secroot, "language", "phrases.$_[0]");
|
||
|
|
open (TMPFILE, ">$tmpfile") or return 0;
|
||
|
|
for (0 .. $#sTranslation) {
|
||
|
|
print TMPFILE "$sTranslation[$_]\n";
|
||
|
|
}
|
||
|
|
close TMPFILE;
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# $access = &ipfilteredaccess($filtermasks, $visitorip);
|
||
|
|
#
|
||
|
|
# RETURNS 0 = access denied
|
||
|
|
# 1 = access permitted
|
||
|
|
#
|
||
|
|
# ipaddress filters can be submitted in pairs separated by a comma
|
||
|
|
# xxxx:nnn.sss.bbb.mmm,xxxx:nnn.sss.bbb.mmm
|
||
|
|
# x = A (absolute match of segment required)
|
||
|
|
# x = M (masked LOGICAL AND match of segment required)
|
||
|
|
# if x is omitted, all segments are treated as masked.
|
||
|
|
#
|
||
|
|
sub ipfilteredaccess {
|
||
|
|
my $visitor = $_[1];
|
||
|
|
my $visitortocheck = $_[1];
|
||
|
|
my @filters = split(/\,/, $_[0]);
|
||
|
|
my @rslt = ();
|
||
|
|
my @filtersegs = ();
|
||
|
|
my @applymask = ();
|
||
|
|
my @visitsegs = split(/\./, $visitor);
|
||
|
|
my $filter = "";
|
||
|
|
foreach $filter (@filters) {
|
||
|
|
(my $segeval, my $ipmask) = split(/:/, lc($filter));
|
||
|
|
if ($ipmask eq '') { $ipmask = $segeval; $segeval="MMMM";}
|
||
|
|
@filtersegs = split(/\./, $ipmask);
|
||
|
|
@applymask = split(//,$segeval);
|
||
|
|
for (0 .. $#filtersegs) {
|
||
|
|
use integer;
|
||
|
|
if ($applymask[$_] eq "A") {
|
||
|
|
@rslt[$_] = ($visitsegs[$_] eq $filtersegs[$_]) ? $visitsegs[$_] : 0;
|
||
|
|
} elsif ($applymask[$_] eq "M") {
|
||
|
|
@rslt[$_] = int($visitsegs[$_]) & int($filtersegs[$_]);
|
||
|
|
} else {
|
||
|
|
@rslt[$_] = 0;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$visitor = "$rslt[0].$rslt[1].$rslt[2].$rslt[3]";
|
||
|
|
@rslt = ();
|
||
|
|
@filtersegs = ();
|
||
|
|
@applymask = ();
|
||
|
|
if ($visitor eq $visitortocheck) {
|
||
|
|
@filters = ();
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
@filters = ();
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
## v support for self-registration
|
||
|
|
sub setbrowsertype {
|
||
|
|
$SESSION{'useragent'}=$ENV{'HTTP_USER_AGENT'};
|
||
|
|
if ($FORM{'browser'} eq '') {
|
||
|
|
if ($SESSION{'useragent'} =~ /MSIE/ ) {
|
||
|
|
$FORM{'browser'} = "MSIE/4";
|
||
|
|
} else {
|
||
|
|
$FORM{'browser'} = "NSNV/4";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
($SESSION{'browserapp'}, $SESSION{'browserversion'}) = split(/\//, $FORM{'browser'});
|
||
|
|
}
|
||
|
|
## ^ support for self-registration
|
||
|
|
|
||
|
|
## v sac modification to standardize test sequence inputs
|
||
|
|
sub print_client_seqtst_list {
|
||
|
|
my ($clid, $tseq, $tdefault, $fh) = @_;
|
||
|
|
$fh = (defined($fh) ? $fh : *STDOUT);
|
||
|
|
my @recs=();
|
||
|
|
my @trecs=();
|
||
|
|
my $grepfor;
|
||
|
|
my $rec;
|
||
|
|
my $id;
|
||
|
|
my $desc;
|
||
|
|
my $tmd;
|
||
|
|
my $maxtm;
|
||
|
|
my $seq;
|
||
|
|
my $etc;
|
||
|
|
my $html;
|
||
|
|
my $selected="";
|
||
|
|
|
||
|
|
if ($tseq eq 'cfa') {
|
||
|
|
$grepfor="(.*)\&cfa\&(.*)";
|
||
|
|
} elsif (($tseq eq 'profb') || ($tseq eq 'profa')) {
|
||
|
|
$grepfor="(.*)\&(std|svy|dmg|adp)\&(.*)";
|
||
|
|
} elsif ($tseq eq 'srvy') {
|
||
|
|
$grepfor="(.*)\&(std|svy|dmg|adp)\&(.*)";
|
||
|
|
}
|
||
|
|
|
||
|
|
@recs = &get_data("tests.$clid");
|
||
|
|
$rec = shift @recs;
|
||
|
|
if ($#recs != -1) {
|
||
|
|
@trecs=grep( /$grepfor/, @recs);
|
||
|
|
if ($#trecs != -1) {
|
||
|
|
@recs=();
|
||
|
|
foreach $rec (@trecs) {
|
||
|
|
($id,$desc,$tmd,$maxtm,$seq,$etc)=split(/&/, $rec);
|
||
|
|
if (($grepfor =~ /$seq/i) && ($id ne $TEST{'id'})) {
|
||
|
|
$rec = join('&',$desc,$id);
|
||
|
|
push @recs, $rec;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($#recs != -1) {
|
||
|
|
@trecs=@recs;
|
||
|
|
@recs = sort @trecs;
|
||
|
|
@trecs=();
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$seq = ($tseq eq 'cfa') ? 'dscl' : $tseq;
|
||
|
|
$html="<select name=\"$seq\">\n";
|
||
|
|
foreach $rec (@recs) {
|
||
|
|
($desc,$id)=split(/&/, $rec);
|
||
|
|
$selected = ($id eq $tdefault) ? " selected" : "";
|
||
|
|
$html= join('',$html,"<option value=\"$id\"$selected>$desc\n");
|
||
|
|
@flds=();
|
||
|
|
}
|
||
|
|
if ($tdefault eq '') {
|
||
|
|
$html= join('',$html,"<option value=\"\" selected>None\n");
|
||
|
|
} else {
|
||
|
|
$html= join('',$html,"<option value=\"\">None\n");
|
||
|
|
}
|
||
|
|
$html= join('',$html,"</select><br>\n");
|
||
|
|
return $html;
|
||
|
|
}
|
||
|
|
## ^ sac modification to standardize test sequence inputs
|
||
|
|
|
||
|
|
sub print_user_language_select {
|
||
|
|
my ($clid, $dropdown) = @_;
|
||
|
|
@allowed_langs = split(/,/, $SYSTEM{'ALLOWEDLANGS'});
|
||
|
|
if ($CLIENT{'cllangflags'} eq "Y" && $dropdown != 1) {
|
||
|
|
print "$xlatphrase[541]<BR>\n";
|
||
|
|
foreach $lang (@allowed_langs) {
|
||
|
|
print "<a href=\"#top\" name=\"$LANGUAGE_ID{$lang}\" onClick=\"return language_select('$lang')\">\n";
|
||
|
|
print "<img src=\"$graphroot/$LANGUAGE_FLAG{$lang}\" border=0 Alt=\"$LANGUAGE_ID{$lang}\"></a>\n";
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
print " $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);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
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 @searching = &get_data($_[0]);
|
||
|
|
my $getlegend = shift(@searching);
|
||
|
|
chomp($getlegend);
|
||
|
|
my @labels = split( '&', $getlegend);
|
||
|
|
my @fields = ();
|
||
|
|
my %megahash =();
|
||
|
|
foreach (@searching) {
|
||
|
|
chomp $_;
|
||
|
|
if (/^$match&/) {
|
||
|
|
@fields = split( '&', $_);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
my $hashlength = $#labels;
|
||
|
|
my $betty;
|
||
|
|
foreach $betty (0..$hashlength) {
|
||
|
|
$megahash{$labels[$betty]} = $fields[$betty];
|
||
|
|
}
|
||
|
|
return $megahash{$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;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# end with True because this is a require file
|
||
|
|
1
|