sub get_form_data

{
my $gbuffer=shift;
my $tmp_varmode=shift;

if ($gbuffer eq "")
{
read(STDIN, $pbuffer, $ENV{'CONTENT_LENGTH'});
$gbuffer = $ENV{'QUERY_STRING'};
}
if ($pbuffer ne "" && $gbuffer ne "")
{ #if getpost is in the post or get buffer then process get before post
which means that values specified in both the get abd post buffer, the post buffer
will take priority, otherwise the get buffer takes priority. Values are processed
sequentially and overwrite previous values so for get to come before post it must
be processed AFTER post buffer, and vice versa
if ($pbuffer=~/getpost/ || $gbuffer=~/getpost/)
{ $buffer=$gbuffer."&".$pbuffer; }
else { $buffer=$pbuffer."&".$gbuffer; }
}
# if only get or only post methods are used then just assign active methods
values to buffer, duplicate values will be pushed into an array and the last value
witll be the dominate one as long as its not empty. A populated var will not be
overwritten by an empty one
elsif ($pbuffer ne "" && $gbuffer eq "")
{ $buffer=$pbuffer; }
elsif ($pbuffer eq "" && $gbuffer ne "")
{ $buffer=$gbuffer; }
&OUTFILE($ENV{'REMOTE_ADDR'}."_buffer.tmp",$buffer,""), if
$ENV{'REMOTE_ADDR'} ne "";

# look for allow list in buffer, if found assign to array and remove from
buffer. Then only process get post vars that are on the allow list , useful for
using a form with any fields but only processing specific fields on that form, like
for event triggers attached to form controles, etc.

if ($buffer=~/allowfields\=([a-z0-9_-]+)/i)
{
@allow = split(/-/, $1);
$Allowlist=1;
}
@pairs = split(/[&]/, $buffer);

foreach $pair (@pairs)

{
$pair=~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
($Name, $value) = split(/=/, $pair);
$Name=~s/\[.+//g;
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
if ($Name =~/txtbox/) {} else { $value =~ s/[\n\r]/ /g; }
$value =~ s/\cM//g; # delete ^M's!
$Fo{$Name} = $value, if $value ne ""; $FoIn.=qq~>$Name=$value~;
#print "****NAME: $Name, VALUE: $value******";
if ($Allowlist==1)
{
foreach $allowfield (@allow)
{
 if ($Name=~/^$allowfield$/)
{
$allowlog.="allowing $Name=$allowfield,";
if ($value=~/.+/)
{
&get_form_data_setfields;
}
}
else { $allowlog.="disallowing $Name !=
$allowfield,"; }
}
$allowlog.="\n--------------\n";
}
else
{
if ($value=~/.+/)
{
&get_form_data_setfields;
}
}
}
sub get_form_data_setfields
{
$Field="Fo_".$Name;
$$Field=$value;
$GField="Gb_".$Name;
$$GField=$value;
$JS_GLOBALS.=qq~$GField='$value'; ~;
$PL_GLOBALS.=qq~$Field==$value|$GField==$value|~;

$setcookies.=qq~Set-Cookie: $Name=$value; Max-Age=17000; Path=/;\n~;

# generate SQLTAG variable set which will be used to send form fields
to $SQLTAG_FORMVARS which can be used to pas form vars to the SQL tags which are
then passed to the shell
$SQLTAG_FORMVARS.=qq~$Field==$value|~;
# push scalar into an array, if there is more than one value in thr
form with the same name like in check boxes or multiselect, perl will know where to
find them for loops
push (@$Field, $value);
# varmode 'real' means, if indicated, create a variable from the form
fields that has its same name as sent in the GET or POST , i.e. $name = 'john' ,
this is in ADDITION to prefexid versions like Fo_name
$$Name=$value, if $value ne "" && $Fo_varmode eq "real" || $tmp_varmode
eq "real";
}
$qtime = localtime();
$buff_me_up=$buffer; $buff_me_up=~s/\&+/\n/gi;

my $tmpEnv = $ENV{'SCRIPT_NAME'};
$tmpEnv=~s/.+\///gi;
$postdate=`date`; chomp($postdate);
$post_vals="<pre>\n############## $tmpEnv ####################\nT:$postdate\
nS:$ENV{'SCRIPT_NAME'}\nP:$pbuffer G:$gbuffer\n$buff_me_up\n</pre>\n";
&OUTFILE("/cc2/CMD_HIST_POSTS.DAT",$post_vals,"APPEND");
return $buffer;
}
sub FORKOFF
{
use POSIX 'setsid';
 # shell commands
my $tmpcmd=shift;
# subs (tmpsub1,tmpsub2)
my $tmpsub=shift;
my $tmpsub1=shift;
my $tmpsub2=shift;

my $pid = fork();
if ($pid == 0)
{
# Child process
chdir '/'; # Change working directory
open STDIN, '/dev/null'; # Redirect STDIN
open STDOUT, '>/dev/null'; # Redirect STDOUT
open STDERR, '>&STDOUT'; # Redirect STDERR to STDOUT
setsid(); # Create a new session

# Your background task here

`$tmpcmd`, if $tmpcmd=~/.+/;
&$tmpsub($tmpsub1,$tmpsub2), if $tmpsub=~/\w+/;
exit(0);
}
}

sub LISTVARS
{
$script_name=shift;

@TMPSCRIPT=split(/\n/, `cat $script_name`);

foreach $line (@TMPSCRIPT)
{
$varref=""; $subref=""; $arrayref="";
$line=~/\$([a-zA-Z0-9_-]+)|sub ([a-zA-Z0-9_-]+)|\@([a-zA-Z0-9_-]
+)/;
$varref=$1; $subref=$2; $arrayref=$3;
push (@VARREF, $varref),$vars.="<!--$script_name: $varref=$
$varref-->\n", if $$varref=~/\w/ && $varref ne $lastvarref;

push (@ARRAYREF, $arrayref),$vars.="<!--$script_name: \$

$arrayref[0]=$$arrayref[0]-->\n", if $$arrayref[0]=~/\w/ && $arrayrref ne
$lastarrayref;
# push (@SUBREF, $subref),print "\&$subref\n", if $subref=~/\w/;
$lastvarref=$varref;
$lastarrayref=$arrayref;
}
OUTFILE("tmp.vars",$vars,"");
$returnvars=`cat tmp.vars|sort -u`;
return $returnvars;

}
sub Base64encode
{
my $tmp_content = shift;
&WHAT_TIME;
&OUTFILE("$wtSecEpoch$wtSecNano.tmp",$tmp_content,"");
#print $tmp_content;
my $tmp_content64=`cat $wtSecEpoch$wtSecNano.tmp|base64`;
`rm -f $wtSecEpoch$wtSecNano.tmp`;
$tmp_content64=~s/[^A-Za-z0-9]//g;
 return $tmp_content64
}
sub Base64decode
{
my $tmp_content64 = shift;
&WHAT_TIME;
&OUTFILE("$wtSecEpoch$wtSecNano.tmp",$tmp_content,"");
#print $tmp_content;
my $tmp_content=`cat $wtSecEpoch$wtSecNano.tmp|base64 -d -i`;
`rm -f $wtSecEpoch$wtSecNano.tmp`;
return $tmp_content;
}
sub UPLOADFILE
{
my $filedone = shift;
$filetmp=$filedone.".tmp";
# Retreive the uploaded file
my $bytes_retreived = 0;
my $bufsize = 1024;
my $limit = 5000000; # 1 MB limit
my $buffer = '';
# Open tempfile for writing
open (TMPFILE, ">$filetmp");
binmode TMPFILE; # To be sure MS Windows binary files don't get corrupted.
while (($bytes_retreived <= $limit) && read ($fh, $buffer, $bufsize))
{
print TMPFILE $buffer;
$bytes_retreived += $bufsize;
}
close TMPFILE;
# Failure (file too big), remove tempfile
if ($bytes_retreived >= $limit)
{
$error .= "Error: File <b>$filename</b> too big. (max size = " .
filesizesuffix($limit) . ")<br>";
unlink $filetmp
or $error .= "Error: Deleting uploaded part of too big file failed: $!
<br>";
}
# Success, rename tempfile to uploaded file
else
{
rename $filetmp, $filedone
or $error .= "Rename file failed: $!<br>";
$msg .= "File <b>$filename</b> uploaded succesfully.<br>" unless $error;
}

}
sub TRACEVARS
{
my $thisscript = shift;
$thisscript=$ENV{'SCRIPT_NAME'}, if $thisscript eq "";
$thisscript=~s/.+\///g;

$extrc="cat ./$thisscript|perl -s ./listvars.pl|sort -u";

#print $extrc;
print qq~\n<pre><!--====================.
$thisscript============================\n~;
@xx=split(/[\n\r]/, `$extrc`);
 foreach $v (@xx)
{ chomp($v); print "$v=$$v\n",
if $$v; }
print qq~\
n================================================--></pre>\n~;
&WAIT, if $wait;
}
sub PAIRS2VARS
{
$tmpNVPairs = shift;
$tmpPrefix=shift;
my $tmpName;
my $tmpValue;

# strip off any http://www.domain.com? from the start of the string if

exists
$tmpNVPairs=~s/^http[^\?]+\?//g;
@tmpPairs = split(/[\&]/, $tmpNVPairs);

foreach $tmpPair (@tmpPairs)

{
($tmpName, $tmpValue) = split(/\=/, $tmpPair);
if ($tmpPrefix=~/\w+/)
{
$tmpCustomName=$tmpPrefix."_".$tmpName;
$$tmpCustomName=$tmpValue;
$tmpNames.="$tmpCustomName,";
$pairs2vars.="<!--$tmpCustomName=$tmpValue-->", if
$Fo_debug;
$JS_GLOBALS.=qq~$tmpCustomName='$tmpValue'; ~;
$PL_GLOBALS.=qq~$tmpCustomName==$tmpValue|; ~;

}
else
{
$$tmpName=$tmpValue;
$tmpNames.="$tmpName,";
$pairs2vars.="<!--$tmpName=$tmpValue-->", if
$Fo_debug;
$JS_GLOBALS.=qq~$tmpName='$tmpValue'; ~;
$PL_GLOBALS.=qq~$tmpName==$tmpValue|;~;

}
# create a 'soft' global, Gb_ only populate if empty, this allows
for a global to be set in the script, but if the same var is passed in the url it
will take preference
$GbcustomName="Gb_".$tmpName;
if ($$GbcustomName eq "")
{
$$GbcustomName=$tmpValue;
$JS_GLOBALS.=qq~$GbcustomName='$tmpValue'; ~;
}
}
$tmpNames=~s/,$//g;
return $tmpNames;
}
sub HTM_KATCH
{
$tmp_htm_input = shift;
 $tmp_htm_filename = shift;
$tmp_htm_filename =~ s/\.htm$//gi;
# IF INPUT LOOKS LIKE A FILENAME AND 2ND ARG IS NOT PRESENT, RETUENS THE
CACHED COPY IMMEDIETLY IF CACHED COPY IS FOUND
if ($tmp_htm_input=~/[a-z0-9_\-]+$/i && $tmp_htm_filename eq "")
{ $tmp_htm_cached_content=`cat /cserv/htm/htm_katch/$tmp_htm_input\.htm`;
if ($tmp_htm_cached_content eq "") { return "<!--$tmp_htm_input ERROR
or FILE EMPTY-->"; }
else { return $tmp_htm_cached_content; }
}
# IF INPUT IS HTM OR CONTENTS THEN A FILENAME MUST ALSO BE SPECIFIED AS THE
SECOND ARG WHEN CALLED, IN THIS CASE IT SAVES THE CACHECD CONTSNTS TO THE FILENAME
SPECIFIED. if the file is not in the cache, indicating that this could be the first
time that this file has been placed in the cache, then return the contents of the
file, but if the file DOES already exist then its assumed that its already been
printed to the screen before this new copy has been generated, and so it returnes
SILENTLY. this allows HTM_CACHE to be used in pairs, once before and once after any
lengthy processes that cause a page load time lag.
elsif ($tmp_htm_filename=~/[a-z0-9_-]+$/i && $tmp_htm_input ne "")
{
# 1 - SEE IF FILE EXISTS ALREADY
$tmp_fc=`ls -1 /cserv/htm/htm_katch/$tmp_htm_filename\.htm|wc -
l`; chomp ($tmp_fc);
# 2. - OVERWRITE REGARDLESS , WITH THE UPDATED ONE (arg 1)
&OUTFILE("/cserv/htm/htm_katch/$tmp_htm_filename\.htm",
$tmp_htm_input);
# 3 - NOW RETURN SILENT OR RETURN SAVED INPUT IF CREATING NEW
FILE
if ($tmp_fc > 0) { return "<!-- htm katch found $tmp_fc files
called $tmp_htm_filename- saved new complete -->"; }
else { return $tmp_htm_input; }
}
else { return "<!-- error, mismatching conditions; $tmp_htm_filename -->"; }

}
sub COUNTLINES
{
my $tmpf=shift;
$tmppcc=`wc -l $tmpf`;
chomp($tmppcc);
return $tmppcc;
}
sub SLEEP
{
`sleep $_[0]`;
}
sub screenpipe
{
my $scname=$_[0];
my $scdata=$_[1];

if ($scdata eq "new")
{
&WHAT_TIME("");
$wtSecNano=~/([0-9][0-9][0-9])$/;
$scid=$1;
return "$scname-$scid";
}
 else
{ $scout=`echo "$scdata" | socat PIPE,echo=0 "EXEC:'screen -S $scname -d
-R',pty,setsid,ctty"`;
return $scout;
}
}
sub COLLATE
{
# Initializing temporary variables
$tmp_tot_per_page = 0 ; $tmp_tot_elements = 0;
# Retrieving the number of elements per page and total elements
$tmp_tot_per_page=shift;
$tmp_tot_elements=shift;
# Check if input values are valid
print "cant collate. input values must be above zero",return, if
$tmp_tot_per_page < 1 || $tmp_tot_elements < 1;
# Initialize current page number and line count
$tmp_current_page_number=1;
$tmp_current_line_count=1;
# Calculate the total number of pages
$tmp_tot_pages=$tmp_tot_elements / $tmp_tot_per_page;
# If there are leftover elements, increment the total page count
if ($tmp_tot_pages=~/(\d+)(\..+)/) { $tmp_tot_pages=$1; $tmp_tot_pages++; }

# Start rearranging the sequence until all elements are processed

until ($tmp_current_line_count==$tmp_tot_elements)
{
# Calculate the output number for the current position
$tmp_output_count=($tmp_tot_pages * $tmp_pagebreak_line_count) +
$tmp_current_page_number;

# Increment counters for current line and page break line

$tmp_current_line_count++;
$tmp_pagebreak_line_count++;

# Store the calculated number in an array

push (@tmp_output_countainer, $tmp_output_count);
# Debugging output, if enabled
print "$tmp_output_count,", if $Fo_debug;

# Check if the end of a page is reached

if ($tmp_pagebreak_line_count==$tmp_tot_per_page)
{
# Debugging output, if enabled
print "\n$tmp_current_page_number --> ",if $Fo_debug;
# Reset the page break line count
$tmp_pagebreak_line_count=0;
# Increment the current page number
$tmp_current_page_number++;
}
}
# Final debugging output, if enabled
if ($Fo_debug ne "")
{
print "\n\n";
foreach $tmp_output_element (@tmp_output_countainer) { print
"$tmp_output_element,"; }
}
# Return the rearranged sequence
 return @tmp_output_countainer
}

sub bashcolor
{
$Co1=$_[0];
$Co2=$_[1];

$shBl='#[1;34m';
$shRe='#[31;47m';
$shGr='#[32;47m';
$shYe='#[33;40m';
$shBl='#[34;47m';
$shPu='#[35;47m';
$shCy='#[36;47m';
$shWh='#[37;47m';

$shCol=qq~#[$Co1;$Co2m#[0m~;
return $shCol, if $Co1 ne "" && $Co2 ne "";
}
sub PUSHOVER
{
$tmpMessage=$_[0];

use LWP::UserAgent;

LWP::UserAgent->new()->post
(
"https://api.pushover.net/1/messages.json",
[
"token" => "a4rimc12xyLopHJaosJ5DcEJz5BSAz",
"user" => "u5fVVqGoLH6nA7Uzndef3M7pTFqCFn",
"html" => "1",
"message" => $tmpMessage,
]
);

# `curl -s --form-string "token=a4rimc12xyLopHJaosJ5DcEJz5BSAz" --form-string

"user=u5fVVqGoLH6nA7Uzndef3M7pTFqCFn" --form-string "message=hello world\u000ahow
are ya\u000a<b>RIGHT</b>" https://api.pushover.net/1/messages.json`;
}
sub GREP_FORMVARS
{ #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!DEPRECIATED USE GREPOPS
$temp_htm=$_[0];

# very clever system for carrying over form vals for lists,options and
checkboxes
# simply add the fname="fieldname" to each option in a list of html
options, fieldname should match the name of the formfield for the option list that
the options are contained within. this allows perl to see them and add the
''selected' flag to any options that wer submitted which match the same field name.
this is really useful for returning a page for example that needs to be submitted
again, and you want to save the user from having to re-check any boxes or options.
creates form memory for select lists. clever, i know.

@SPLITHTM=split(/\n/, $temp_htm);
foreach $tmpline (@SPLITHTM)
{
if ($tmpline=~/option fname="?([^" ]+)"? value="([^"]+)"/i)
 {
#print qq~$1,$2,$Fo{$1},$Fo{$1}<br>~; - testing
if ($2 eq $Fo{$1})
{
$tmpline=~s/option *fname/option selected="selected"
fname/gmi;
}
}
if ($tmpline=~/checkbox"? name="([^"]+)" +value="([^"]+)"/i)
{
#print qq~$1,$2,$Fo{$1},$Fo{$2}<br>~;
if ($2 eq $Fo{$1})
{
$tmpline=~s/value=/checked="checked" value=/gmi;
}
}
if ($tmpline=~/radio"? +name="([^"]+)" +value="([^"]+)"/i)
{
#print qq~$1,$2,$Fo{$1},$Fo{$2}<br>~;
if ($2 eq $Fo{$1})
{
$tmpline=~s/value=/checked value=/gmi;
}
}
$temp_htm_new.=$tmpline."\n";
}
$temp_htm_new=~s/\$([a-z][a-z0-9_]+)/$$1/gmi;
#exit;
return $temp_htm_new;
}
sub CALCWORKDAYS {

my ($startdoy, $enddoy) = @_;

# Calculate the total days between the start and end day of the year
my $total_days = $enddoy - $startdoy;

# Calculate the number of full weeks

my $full_weeks = int($total_days / 7);

# Calculate the remainder days

my $remainder_days = $total_days % 7;

# Calculate the number of non-working weekend days

my $non_working_days = $full_weeks * 2;
my $start_weekday = ($startdoy + 4) % 7;

# Check if the remainder days fall on or after a Saturday

for (my $i = 0; $i < $remainder_days; $i++) {
if (($start_weekday + $i) % 7 >= 5) {
$non_working_days++;
}
}
# Calculate the total workdays
my $workdays = $total_days - $non_working_days;

return $workdays;
}
sub wGET_COOKIE
{
use CGI;
# LOAD THE COOKIES
$query = new CGI;
$gbuffer = $query->cookie('gbuffer');
$pbuffer = $query->cookie('pbuffer');
# $gbuffer = `cat $gbuffer64|base64 -d|base64 -i -d`;
# $pbuffer = `cat $pbuffer64|base64 -d|base64 -i -d`;

}
sub wSET_COOKIE
{
use CGI;
$query = new CGI;
#$gbuffer64=`cat $gbuffer|base64|base64 -i`;
# $pbuffer64=`cat $pbuffer|base64|base64 -i`;
$cookie1 = $query->cookie(-name=>'gbuffer',
-value=>$gbuffer,
-expires=>'+4d');

$cookie2 = $query->cookie(-name=>'pbuffer',
-value=>$pbuffer64,
-expires=>'+4d');

print $query->header(-type=>"text/html",-charset=>"utf-8",-
cookie=>[$cookie1,$cookie2]);

$cookie_set=1;
}

sub SQLTAGS
{
my $tmpHtm = shift;
my $tmpFile = shift;
my $tmpMode = shift;
my $tmpcc=0;
my $tmpLine;
my $tmpResult = "";
my $tmpHtmOut = "";
my @TMPGREPHTM=();
# tmpHtm can be actual html or a file ref, acton determined here
if ($tmpFile=~/\w+/)
{
$thispage=$tmpFile;
$tmpHtm = `cat ../htm/$tmpFile.htm`;
}

@TMPGREPHTM=split(/[\n\r]/, $tmpHtm);
if ($Fo_tagpattern) { @TMPHTM = grep(/<\!--SQL.+$Fo_tagpattern.*--\>/,
@TMPGREPHTM); }
else { @TMPHTM = grep(/.+/, @TMPGREPHTM); }

# SCAN EACH LINE FOR A SQLTAG

foreach $tmpLine (@TMPHTM)
{
if ($tmpLine=~/\<\!--SQLVARS_SINGLE:([^\|]+)\|?([^\|]*)--\>/)
{
 $tmpq=$1; $tmpdb=$2;
$tmpq=~s/\$([a-z0-9_]+)/$$1/gi;
SQLVARS_SINGLE($tmpq,$tmpdb);
$PhoneNumericTmp=$Phone; $PhoneNumericTmp=~s/[^0-9]//g;
#bad practice but why the hell not
}
elsif ($tmpLine=~/\<\!--GETSEGS:([^\|]+)\|?([^\|]*)\|?([^\|]*)?--\>/)
{
$_tmpHtmOut=`./ccerv.cgi -Fo_get=$1 -Fo_seg=$2`;
#GETSEGS($1,$2); print "<!--GETSEGS $1|$2-->";
$_tmpHtmOut=~s/Content-type: text.html;charset=UTF-8//gi;
$tmpHtmOut.=$_tmpHtmOut;
$_tmpHtmOut="";
}
elsif ($tmpLine=~/\<\!--SQLVARS:(\w+.+)\|?([^\|]*)\|?([^\|]*)\|?
([^\|]*)--\>/)
{ SQLVARS($1,$2,$3,$4); }
elsif ($tmpLine=~/\<\!--SUB:([^\|]+)\|?([^\|]*)\|?([^\|]*)?--\>/)
{
$tmpa=$1; $tmpb=$2; $tmpc=$3;
$tmpa=~s/\$([a-z0-9_]+)/$$1/gi;
$tmpb=~s/\$([a-z0-9_]+)/$$1/gi;
$tmpc=~s/\$([a-z0-9_]+)/$$1/gi;
$tmpHtmOut.=&$tmpa($tmpb,$tmpc); #print "<!--SUB $tmpa|
$tmpb|$tmpc-->";
$tmpa=""; $tmpb=""; $tmpc="";
}
elsif ($tmpLine=~/\<\!--QSUB:([^\|]+)\|?([^\|]*)\|?([^\|]*)?--\>/) #run
sub with no output
{
$tmpa=$1; $tmpb=$2; $tmpc=$3;
$tmpa=~s/\$([a-z0-9_]+)/$$1/gi;
$tmpb=~s/\$([a-z0-9_]+)/$$1/gi;
$tmpc=~s/\$([a-z0-9_]+)/$$1/gi;
&$tmpa($tmpb,$tmpc); #print "<!--SUB $tmpa|$tmpb|$tmpc-->";
$tmpa=""; $tmpb=""; $tmpc="";
}
elsif ($tmpLine=~/\<\!--SHELL:(.+)--\>/)
{
$tmpShellCmd=$1;
$tmpShellCmd=~s/\$([a-z0-9_]+[a-z0-9])/$$1/gi;
$tmpHtmOut.=`$tmpShellCmd`."\r\n";
}
elsif ($tmpLine=~/\<\!--AJAX:(\w+)\|([^\|]+)\|([^\|]+)--\>/)
{
$tmpccd++;
$tmpAjax=qq~var formObj$tmpccd$wtSecEpoch = new
DHTMLSuite.form({ formRef:'$1',action:'$2',responseEl:'$3'});
formObj$tmpccd$wtSecEpoch.submit('$1')~;
$tmpLine=~s/\<\!--AJAX:.+--\>/$tmpAjax/gi;
}
elsif ($tmpLine=~/\<\!?--SQLTAG:(\w+==.+)--\>/)
{
# PRE VARS - swap out $vars with current assiciated vars, note
that $words are swapped BEFORE the tag vars are parsed.
# this way if a tagvar has the same name as the form (Fo_var) the
Form vars value will be used instead of the tag var. this way default
# var vals can be set on the html side, and only modified if
detected in the post-get input
 $tmpSqlPairs=$1;
$tmpSqlPairs=~s/\$([a-z0-9_]+)\[(\d+)\]/$$1[$2]/gi;
$tmpSqlPairs=~s/\$([a-z0-9_]+)/$$1/gi;

### THE MEAT OF THE TAG IS KEY VAL PAIRS == SEPRATED, |

TREMINATED PARING INTO SCALARS
# SPLIT PAIRS INTO ARRAY
@TMPSQLPAIRS=split(/\|/, $tmpSqlPairs);
# LOOP THROUGH EACH PAIR
foreach $tmpNVPair (@TMPSQLPAIRS)
{
$tmpName=""; $tmpValue="";
# SPLIT EACH PAIR INTO ASSOCIATED SCALAR
($tmpName, $tmpValue) = split(/==/, $tmpNVPair);
# this means that if a form var is passed it will
take preference over the same var defined in a sql tag. this way the default of a
var can be set per table but any one of them can be overwridden via form, so that
for example self embedded sort links willl worrk the first time without a fault,
etc.
if ($Fo{$tmpName}=~/.+/ && $tmpName ne "mode")
{
$$tmpName = $Fo{$tmpName};
print qq~<!--FoVar $tmpName=$$tmpName-->\n~;
}
else
{
$$tmpName = $tmpValue;
print qq~<!--SqlTagVar $tmpName=$$tmpName-->\
n~;
$GbName="Gb_".$tmpName;
$$GbName=$tmpValue;
$tmpName='$tmpValue';
$JS_GLOBALS.=qq~$GbName='$tmpValue';~;
}
}

# FLIP FLOP DESC ASC FOR DYNAMIC SORTING,

if ($Fo_desc eq "desc") { $desc="asc"; }
elsif ($Fo_desc eq "asc") { $desc="desc"; }
else { $desc="desc"; }

# POST VARS REPLACE ANY **VARIABLES IN THE QUERY WITH THE

ASSOCIATED VARIABLES CONTENTS , using **vars inside the -q var so that they cant be
accidently swapped outby previous operations.
$q=~s/\*\*([a-z0-9_]+)\[(\d+)\]/$$1[$2]/gi;
$q=~s/\*\*([a-z0-9_-]+)/$$1/gi;
# RUN SQL FETCH
$itr++;
$tmpResult = `./FechSQL.pl -q="$q" -DB=$DB -mode=$mode -
file=$htmfile -remote_ip=$ENV{'REMOTE_ADDR'} -seg=$htmseg -itr=$itr -
Fo_showsql=$Fo_showsql`, if $q ;
# edit results by applying this regular expression if the regfind
variable is populated in the tag
$tmpResult=~s/$regfind/$regreplace/gi, if $regfind;
# ir no result, use whatever is in the onEmpty var
if ($tmpResult=~/\w/) {} else { $tmpResult=$onEmpty; }
print $tmpResult, if $Fo_debug;
# INSERT TABLE CLASS ATTRIBUTES IF RESULT IS A TABLE
if ($mode eq "H")
 {
if ($q=~/ ob / || $q=~/ order by /)
{ $tmpResult=~s~(\<TH\>)(\w+)~$1<input name="add-invoice-
multi" type="button" class="$buttonclass" form="form_sqlvar_result_$tmpcc"
onClick="var object_sqlvar_result_$tmpcc = new
DHTMLSuite.form({ formRef:'form_sqlvar_result_$tmpcc',action:'?
tagpattern=$tagpattern&$buffer&ob=$2&desc=$desc',responseEl:'sqlvar_result_$tmpcc'}
); object_sqlvar_result_$tmpcc.submit('form_sqlvar_result_$tmpcc');" value="$2"
data-ajax="false" data-role="none"><\/input>~gi; }
$tmpResult=~s/\<TH/<TH id="$thid" class="$thclass"/gi;
$tmpResult=~s/\<TR/<TR id="$trid" class="$trclass"/gi;
$tmpResult=~s/\<TABLE/<TABLE id="$tableid"
class="$tableclass" style="$tablestyle"/gi;
$tmpResult=~s~(.+)~<div
id="sqlvar_result_$tmpcc">\n$1\n</div>~gi;
$tmpResult.=qq~<form id="form_sqlvar_result_$tmpcc"
name="form_sqlvar_result_$tmpcc"> </form>~;
}
$q=""; $DB=""; $file=""; $seg="";$mode="";
$tmpResult=~s/NULL/0/g;
$tmpResult=~s/[\*\%][\*\%]([a-z0-9_-]+)/$$1/gi; # tricky, if
results from sql contain $vars swap with actual var (might come in handy)
# PUSH RESULT INTO RESULT STACK FOR DYNAMIC PLACEMENT (PUSH HERE
EVEN IF OUTPUT IS SUPRESSED (TWSS)
push(@SQLTAG, $tmpResult);
# SWAP OUT TAG WITH RESULT IF EXISTS
$$resvar=$tmpResult, if $resvar; # assign result to named
variable
&OUTFILE("/cserv/htm/tmp/$resfile.htm",$tmpResult), print "<!--
saving $resfile.htm-->", if $resfile;
$tmpLine=~s/\<\!--SQLTAG:(.+)--\>/\n$tmpResult/gi, if $echo ne
"off";
$tmpcc++;
}
# APPEND TMPLINE TO OUTPUT
$tmpLine=~s/\$([a-z0-9_]+)\[(\d+)\]/$$1[$2]/gi;
$tmpLine=~s/\$([a-z0-9_]+)/$$1/gi;
$tmpHtmOut.=$tmpLine."\n";
}
return GREPOPTIONS($tmpHtmOut);
}
sub GETGLOBALS
{
my $varfile=shift;

@GBTMPSQLPAIRS=split(/\|/, `cat $varfile`);

# LOOP THROUGH EACH PAIR
foreach $gbtmpNVPair (@GBTMPSQLPAIRS)
{
$gbtmpName=""; $gbtmpValue="";
# SPLIT EACH PAIR INTO ASSOCIATED SCALAR
($gbtmpName, $gbtmpValue) = split(/==/,
$gbtmpNVPair);
# ASSIGN THEM AS IS
$$gbtmpName = $gbtmpValue;
print qq~<!--GETGLOBALS:
$gbtmpname=$gbtmpValue-->~, if $Fo_debug;
}
}
sub GREPOPTIONS
{
my $gtmpstring=shift;
#print "#################################### $gtmpstring
###########################################";
$gtmpline = "";
$gtemp_htm_new = "";

@SPLITHTM=split(/[\n\r]+/, $gtmpstring);
foreach $gtmpline (@SPLITHTM)
{
if ($gtmpline=~/6REPOPPED/)
{ $gtemp_htm_new.=$gtmpline."<!--GRSKIPPED-->\n"; }
else
{
if ($gtmpline=~/\<select.+name="([^" ]+)"/i)
{ $gfname=$1; }
if ($gtmpline=~/option.+value="([^"]+)"/i)
{
#print qq~<!-- $1,$gfname,$$gfname\n;
$gtmpline-->~, if $Fo_showsql eq "on";
if ($1 eq $$gfname)
{
$gtmpline=~s/<option /<option
selected="selected" /gmi;
$tmppp="<!--
6REPOPPED:1=$1,2=$2,Fo{1}=$Fo{$1},Fo{2}=$Fo{$2}-->\n", if $Fo_showsql eq "on";
print $tmppp; $gtmpline.=$tmpppl;
}
}

if ($gtmpline=~/input.+type="text"/ &&
$gtmpline=~/name="([^"]+)"/i)
{
print qq~<!-- $1,$gfname,$$gfname\n;
$gtmpline-->~, if $Fo_showsql eq "on";
if ($Fo{$1} ne "")
{
$gtmpline=~s/value="([^"]*)"//gmi;

$gtmpline=~s/name="([^"]+)"/name="$1" value="$Fo{$1}"/gmi;
$tmppp="<!-- 6REPOPPED:name:$1
value:$Fo{$1} type:text-->\n", if $Fo_showsql eq "on";
print $tmppp; $gtmpline.=$tmpppl;
}
}
if ($gtmpline=~/checkbox"?/ &&
$gtmpline=~/name="([^"]+)".+value="([^"]+)"/i)
{
#print qq~$1,$2,$Fo{$1},$Fo{$2}<br>~;
if ($2 eq $$1)
{

$gtmpline=~s/value=/checked="checked" value=/gmi;
$tmppp="<!--
6REPOPPED:1=$1,2=$2,Fo{1}=$Fo{$1},Fo{2}=$Fo{$2}-->\n", if $Fo_showsql eq "on";
print $tmppp; $gtmpline.=$tmpppl;
}
 }
if ($gtmpline=~/radio"?/ &&
$gtmpline=~/name="([^"]+)".+value="([^"]+)"/i)
{
#print qq~$1,$2,$Fo{$1},$Fo{$2}<br>~
if ($2 eq $$1)
{
$gtmpline=~s/value=/checked
value=/gmi;
$tmppp= "<!--
6REPOPPED:1=$1,2=$2,Fo{1}=$Fo{$1},Fo{2}=$Fo{$2}-->\n" , if $Fo_showsql eq "on";
print $tmppp; $gtmpline.=$tmpppl;
}
}
if ($gtmpline=~/option.+value="([^"]+)"/i)
{
if ($1 eq $Fo{$gfname})
{
$gtmpline=~s/<option /<option
selected="selected" /gmi;
$tmppp= "<!--
6REPOPPED:OPTION:1=$1,2=$2,Fo{1}=$Fo{$1},Fo{2}=$Fo{$2}-->\n", if $Fo_showsql eq
"on";
print $tmppp; $gtmpline.=$tmpppl;
}
}
if ($gtmpline=~/checkbox"?/ &&
$gtmpline=~/name="([^"]+)".+value="([^"]+)"/i)
{
#print qq~<!--$1,$2,$Fo{$1},
$Fo{$2}-->~, if $Fo_showsql eq "on";
if ($2 eq $Fo{$1})
{

$gtmpline=~s/value=/checked="checked" value=/gmi;
$tmppp="<!--
6REPOPPED:checkbox:1=$1,2=$2,Fo{1}=$Fo{$1},Fo{2}=$Fo{$2}-->\n", if $Fo_showsql eq
"on";
print $tmppp;
$gtmpline.=$tmpppl;
}
}

if ($gtmpline=~/radio"?/ &&
$gtmpline=~/name="([^"]+)".+value="([^"]+)"/i)
{
#print qq~$1,$2,$Fo{$1},
$Fo{$2}<br>~, if $Fo_showsql eq "on";
if ($2 eq $Fo{$1})
{

$gtmpline=~s/value=/checked="checked" value=/gmi;
$tmppp="<!--
6REPOPPED:RADIO:1=$1,2=$2,Fo{1}=$Fo{$1},Fo{2}=$Fo{$2}-->\n", if $Fo_showsql eq
"on";
print $tmppp;
$gtmpline.=$tmpppl;
}
}
 }
$gtemp_htm_new.=$gtmpline."\n";
}
#print qq~<!--\n\n$gtemp_htm_new\n\n-->~, if $Fo_showsql eq
"on";
return $gtemp_htm_new;
}
sub FORM2SQL
{
if ($Fo_q ne "")
{ # if query detected
# swap out $vars and $Fo_vars with submitted info
$Fo_q=~s/ eq / \= /g;
$Fo_q=~s/\*\*([a-z0-9_]+)/$$1/gi;
print $Fo_q, if $Fo_showsql eq "on";
if ($Fo_q=~/^up|^ri|^ii/)
{ FECHALL($Fo_q,$Fo_DB); }

if ($Fo_return_htm ne "")
{
print "<!-- proccesing $Fo_return_htm -->";
print SQLTAGS(GETSEGS($Fo_return_htm,$Fo_segs));
}
}
}
sub GETSEGS
{
my $getsegs_tmpGet=shift; #filename in /htm without .ext
my $getsegs_tmpSegs=shift; # segments seperated by non word chars
my $getsegs_tmpConfig=shift; # a list of segments defined by a <!--CONFIG|
configname|segblah1,segblah2,segblah3-->
my $getsegs_temp_htm = "";
my $getsegs_tmp_out_tmpl = ""; # local yokles
my $getsegs_html;
my $getsegs_seg;
my $getsegs_temp_htm;
my $getsegs_thisSeglabel;
my $getsegs_tmpfoo;
my $getsegs_tmp_out_tmpl;
my $getsegs_tmpseg;

@TTEMP_HTM=();
@TMPSEGS=();
%getsegs_seg=();

if ($getsegs_tmpSegs eq "")
{
$getsegs_config_line=`grep "<!--CONFIG:"
/cserv/htm/$getsegs_tmpGet.htm`;
chomp($getsegs_config_line);
print "$getsegs_config_line";

if ($getsegs_config_line ne "")
{
if ($getsegs_tmpConfig eq "") { $getsegs_tmpConfig="default"; }
$getsegs_config_line=~/CONFIG:$getsegs_tmpConfig:([A-Za-z0-
9_,]+)\-\-/;
$getsegs_tmpSegs=$1;
print "<!--$getsegs_tmpSegs-->";
 }
}
if ($getsegs_tmpSegs eq "") { $getsegs_tmpSegs="head,main,foot"; }
if ($getsegs_tmpGet ne "")
{ # here we split the page by the begining of line comments and
pull out the --words in the center of a page seg indicator and keep it in the split
array
if ($getsegs_tmpGet=~/http/) # get remote file iF http link
detected
{ $getsegs_html=`wget -o - "$getsegs_tmpGet"`; }
if ($getsegs_tmpGet=~/\.js/i) # get java script detected
{ $getsegs_html=`cat /cserv/js/$getsegs_tmpGet`;}
else { $getsegs_html=`cat $GL_HTM_HOME/$getsegs_tmpGet.htm`; }

@TTEMP_HTM=split(/\<\!(--\w+)--\>/, $getsegs_html);
$getsegs_seg{'head'}=$TTEMP_HTM[0];
foreach $getsegs_tmpfoo (@TTEMP_HTM)
{
# if split segment is a lable assign the value of the lable
to the name of the scalar that the next split segment is to be stored within
if ($getsegs_tmpfoo=~/^\-\-(\w+)/)
{
$getsegs_thisSeglabel=$1;
print "!!!!!!!!!!!
$getsegs_thisSeglabel !!!!!!!!!!!!!!!!!!!!", if $Fo_debug;
}
else
{
$getsegs_seg{$getsegs_thisSeglabel} =
$getsegs_tmpfoo;
print $getsegs_seg{$getsegs_thisSeglabel}, if
$Fo_debug;
}
}
@TMPSEGS=split(/[^\w]+/, $getsegs_tmpSegs);
foreach $getsegs_tmpseg (@TMPSEGS)
{
#$getsegs_tmp_out_tmpl.="\n<!--SEG($getsegs_tmpseg)-->\n";
$getsegs_tmp_out_tmpl.= $getsegs_seg{$getsegs_tmpseg};

}
}
print $getsegs_tmp_out_tmpl, if $Fo_debug2;

return $getsegs_tmp_out_tmpl;
}
sub GETSEGS2
{
my $tmpGet=shift; #filename in /htm without .ext
my $tmpSegs=shift; # segments seperated by num umeric chars
my $temp_htm = ""; my $out_tmpl = ""; # local yokles

if ($tmpGet ne "")
{
if ($tmpSegs=~/^\d+/)
{
@TEMP_HTM=split(/\<\!--\d+--\>/, `cat $GL_HTM_HOME/$tmpGet.htm`);

@TMPSEGS=split(/[^\d]+/, $tmpSegs);
 foreach $tmpseg (@TMPSEGS)
{
$out_tmpl.=$TEMP_HTM[$tmpseg], if $tmpseg=~/^\d$/;
}
}
else { $out_tmpl=`cat $GL_HTM_HOME/$tmpGet.htm`; }
}
return $out_tmpl;
}
sub HTMVARS
{
$tmpHtm = shift;
$tmpPrefix = shift;
$tmpFile = shift;

# tmpHtm can be actual html or a file ref, acton determined here

if ($tmpFile=~/\w+/) { $tmpHtm = `cat $GL_HTM_HOME/$tmpFile.htm`; }

@TMPHTMVARS=split(/[\n\r]/, $tmpHtm);

foreach $tmpline (@TMPHTMVARS)

{
$tmpline=~/\<\!--HTMVAR:([a-z0-9_]+)--\>(.+)\<\!--HTMVAR:END--\
>/i;
$HTMVAR_NAME=$1; $HTMVAR_VALUE=$2;
if ($HTMVAR_NAME ne "" && $HTMVAR_VALUE ne "")
{
if ($tmpPrefix=~/[a-zA-Z]+/)
{ $HTMVAR_NAME=$tmpPrefix."_".$HTMVAR_NAME; }
$$HTMVAR_NAME=$HTMVAR_VALUE;
}
$HTMVAR_NAME=""; $HTMVAR_VALUE="";
}
}
sub MAKETABLE
{
$tmp_tmplfile=shift;
$tmp_row_anchor_array_name=shift;
@tmp_maketable_row_anchor=@$tmp_row_anchor_array_name, if
$tmp_row_anchor_array_name;

@TMP_TABLE=split(/\<\!--[0-9]*--\>/, `cat
$GL_HTM_HOME/$tmp_tmplfile.htm`);

$tmp_table=$TMP_TABLE[0];
$tmpcc123=0; $maxcc123=$#tmp_maketable_row_anchor;
if ($maxcc123 == 0 && $tmp_maketable_row_anchor[0] eq "")
{
return "error, missing anchor!";
}

until ($tmpcc123 > $maxcc123)

{
$rowcache=$TMP_TABLE[1];
$rowcache=~s/\<?\!?\-?\-?\*\*([a-z][a-z0-9_]+)\-?\-?\>?/$
$1[$tmpcc123]/gi;
$rowcache=~s/\$([a-z][a-z0-9_-]+)/$$1/gi;

@SPLITHTM=split(/\n/, $rowcache);
 foreach $subtmpline (@SPLITHTM)
{
if ($subtmpline=~/option +fname="([^"]+)"
value="([^"]+)"/i)
{
if ($2 eq $$1[$tmpcc123])
{
$subtmpline=~s/option
*fname/option selected="selected" fname/gmi;
}
}
if ($subtmpline=~/\<tr.+class *= *"([^"]+)"/i)
{

if
($ROWCLASS{$tmp_maketable_row_anchor[$tmpcc123]} ne "")
{
$subtmpline=~s/class *=
*"([^"]+)"/class="$1\_$ROWCLASS{$tmp_maketable_row_anchor[$tmpcc123]}"/gmi;
}
}
$temp_htm_new.=$subtmpline."\n";
}

$tmp_table.=$temp_htm_new;
$temp_htm_new = "";
$tmpcc123++;
}
$tmp_table.=$TMP_TABLE[2];
$tmp_table=~s/\$([a-z][a-z0-9_-]+)/$$1/gi;

return $tmp_table;
}
sub GET_ALL_COOKIES
{
$rcvd_cookies = $ENV{'HTTP_COOKIE'};
@cookies = split /;/, $rcvd_cookies;
foreach $cookie ( @cookies ) {
($key, $val) = split(/=/, $cookie); # splits on the first =.
$key =~ s/^\s+//;
$val =~ s/^\s+//;
$key =~ s/\s+$//;
$val =~ s/\s+$//;
$key =~ s/^([A-Za-z0-9_\.]+)__//g;
next, if $key eq "seg";
if ($1 eq $Fo_get)
{
$newname="Co_".$key;
$$newname=$val;
$cookieassign.="$newname=$val,";
if ($Fo_import eq "Co")
{
$newname="Fo_".$key;
if ($$newname eq "")
{
$val=~s/\'/\\\'/g;
$$newname=$val;
}
}
 $GbcustomName="Gb_".$key;
if ($$GbcustomName eq "")
{
$val=~s/\'/\\\'/g;
$$GbcustomName=$val;
$JS_GLOBALS.=qq~$GbcustomName='$val'; ~;
$PL_GLOBALS.=qq~$GbcustomName==$val|~;
}
}
}
}
sub SET_COOKIE
{
my $cname=$_[0];
my $cvalue=$_[1];
my $ctag=$_[2];

use CGI;
$query = new CGI;

$cookie1 = $query->cookie(-name=>'gbuffer',
-value=>$gbuffer,
-expires=>'+1d');

$cookie2 = $query->cookie(-name=>'pbuffer',
-value=>$pbuffer,
-expires=>'+1d');

# $query->header(-type=>"text/html",-charset=>"utf-8",-
cookie=>[$cookie1,$cookie2]);
$query->header(-cookie=>[$cookie1,$cookie2]);

$cookie_set=1;
}
sub parse_checkboxes
{
foreach $pair (@pairs)
{
($Name, $value) = split(/=/, $pair);
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$value =~ s/\n/ /g; # replace newlines with spaces!
$value =~ s/\r//g; # remove hard returns!
$value =~ s/\cM//g; # delete ^M's!
push (@$Name, $value);
}

}
sub SIMPLEGREP
{
my $tmp_htm=$_[0];
if ($tmp_htm=~/\w+\.htm/) { $tmp_htm=`cat $tmp_htm`; }

$tmp_htm=~s/\$([a-z0-9_]+)/$$1/gmi;
$tmp_htm=~s/\*\*?(\w+)/$Fo{$1}/gi;
$tmp_htm=~s/\~\~(\w+)/$SESS{$1}/gi;

return $tmp_htm;
}
sub PUT_SESS
{
my $temp_sesstype=$_[0];
my $temp_customers_id=$_[1];
my $temp_sessvals=$_[2];
my $temp_sesskey="";

# INSERT THE SESSION

&FECHALL("INSERT INTO enviro_sessions
(ip,sesstype,customers_id,sessvals) VALUES
('$ENV{'REMOTE_ADDR'}','$temp_sesstype','$temp_customers_id','$temp_sessvals')","UB
");

# FECH THE KEY

$temp_sesskey=&FECHALL("SELECT sesskey FROM enviro_sessions WHERE
ip='$ENV{'REMOTE_ADDR'}' AND sesstype='$temp_sesstype' AND
sessvals='$temp_sessvals' ORDER BY sesskey DESC LIMIT 1","UB");

# NOW RETURN THE KEY

return $temp_sesskey;
}
sub GET_SESS
{
my $temp_sesskey=$_[0];

$temp_sessvals=&FECHALL("SELECT sessvals FROM enviro_sessions WHERE

sesskey=$temp_sesskey","UB");

if ($temp_sessvals ne "")
{
@pairs = split(/~/, $temp_sessvals);

foreach $pair (@pairs)

{
($Name, $value) = split(/=/, $pair);
$SESS{$Name} = $value, if $value ne "";
}
return "ok";
}
else { return "fail"; }
}
sub END_SESS
{
my $temp_sesskey=$_[0];
&FECHALL("DELETE FROM enviro_sessions WHERE
sesskey=$temp_sesskey","UB");
}
sub COMMENT
{
my $comment = $_[0];
my $tmpEnv = $ENV{'SCRIPT_NAME'};
$tmpEnv=~s/.+\///gi;
&OUTFILE("/home/joe/public_html/ctmp/CMD_HIST_$tmpEnv.DAT","\
n<br>C:------------------------------------------\n<br> C:$comment\
n<br>C:------------------------------------------\n","APPEND");
}
sub PROCESSQUE
{
 $cc=0;
@Q=split(/\n/, `cat /cc2/SQLQUE/*.SQL`);
print "processing que\n";
foreach $line (@Q)
{
&FECHALL($line);
$cc++;
$line=~/^\w/; print $&;
}
print "\nFINISHED. PROCESSED $cc LINES.";
`mv /cc2/SQLQUE/*.SQL /cc2/SQLQUE/COMPLETED/`;
}
sub HASHME
{
my $INDATA=$_[0];
$_[1] ne "" ? my $splitter=$_[1] : $splitter=":" ;
$_[2] ne "" ? my $hashname=$_[2] : $hashname="SQLHASH";

@Pairs=split(/\n/, $INDATA);

foreach $line(@Pairs)
{
if ($line=~/([A-Z0-9_]+)$splitter *(.+)/i)
{ $$hashname{$1}=$2; }
}
}
sub WHAT_TIME
{
# SET GLOBAL TIME VARIABLES FOR CURRENT TIME OR DATESTRING FROM SUPPLIED IN
ARG
my $tmpThisTime=$_[0];

if ($tmpThisTime ne "") { $dopts=qq~--date="$tmpThisTime" ~; }

else { $dopts=qq~--date="0 hours ago" ~; }
$datecmd="date $dopts +%B~%m~%d~%b~%s~%H~%I~%j~%N~%u~%M~%S~%r~%c~%y~%a~%D~
%Y";
my $datestring=`$datecmd`;
chomp($datestring);
#print qq~*****************\n$datecmd\n********************\n~, if
$Fo_showsql eq "on";
($wtMoCurName,$wtMoCurNum,$wtMoCurDay,$wtMoCurAbv,$wtSecEpoch,
$wtHr24,$wtHr12,$wtYrDayOfNum,$wtSecNano,$wtWkDayOfNum,$wtMinCur,$wtTSecCur,
$wtClock12,$wtTimeStamp,$wtYr,$wtWkDayAbv,$wtDateFull,$wtYrFull)=split(/~/,
$datestring);
$wtYrFulln1=$wtYrFull - 1;
$wtYrFulln2=$wtYrFull - 2;
$wtYrFullNext=$wtYrFull+1;
$wtSecEpochM30=$wtSecEpoch-2592000;

if ($Fo_showsql eq "on")
{
#print qq!
wtMoCurName=$wtMoCurName<br>,wtMoCurNum=$wtMoCurNum<br>,wtMoCurDay=$wtMoCurDay<br>,
wtMoCurAbv=$wtMoCurAbv<br>,wtSecEpoch=$wtSecEpoch<br>,wtHr12=$wtHr12<br>,wtHr24=$wt
Hr24<br>,wtYrDayOfNum=$wtYrDayOfNum<br>,wtSecNano=$wtSecNano<br>,wtWkDayOfNum=$wtWk
DayOfNum<br>,wtMinCur=$wtMinCur<br>,wtTSecCur=$wtTSecCur<br>,wtClock12=$wtClock12<b
r>,wtTimeStamp=$wtTimeStamp<br>wtYr=$wtYr<br>wtWkDayAbv=$wtWkDayAbv<br>date
$dateopts+%B~%m~%d~%b~%s~%H~%I~%j~%N~%u~%M~%S~%T~%c~%y~%a~%D!;
}
}
sub CHECK_RUN_TIME
{
my $tmpRunHrsExpr=$_[0];
my $tmpRunWeekdaysExpr=$_[1];

# USED TO SET THE SCHEDULE ON WHICH DAYS AND HOURS YOU WANT TO ACTIVATE a
SCRIPT. CRON POLLS THIS SCRIPT EVERY 5 MIN (OR WHATEVER SET) , THE RULES BELOW
LOOK AT THE WEEKDAY AND HR TO DECIDE IF THIS IS A WORK DAY AND IF SO, IF THIS IS A
WORK HOUR. IF TRUE, RETURN VALUE OF 'RUN'. TAKES A STRING OF ACCEPTED 2 DIGIT HR
AND 2 DIGIT DAY OF WEEK WITH 01 BEING MONDAY, SEPERATED BY "OR" regex pipes | ..

&WHAT_TIME("6 hours ago");

if ($wtWkDayOfNum=~/$tmpRunWeekdaysExpr/)
{
print "**$&**", if $Fo_showsql eq "on";
if ($wtHr24=~/$tmpRunHrsExpr/)
{
&COMMENT("Running at $wtTimeStamp");
print "**$&**", if $Fo_showsql eq "on";
return "RUN";
}
else { &COMMENT("Exiting at $wtTimeStamp, not right HOUR to run for
$tmpRunWeekdaysExpr,$tmpRunHrsExpr"); return "ABORT"; }
}
else { &COMMENT("Exiting at $wtTimeStamp, not right DAY to run for
$tmpRunWeekdaysExpr,$tmpRunHrsExpr"); return "ABORT"; }
}
sub GET_SNIPPET
{
# RETURNS A RANDOMLY CHOSEN SNIPPET, USEFUL FOR THINGS LIKE BANNER ROTATION,
DAILY TIPS, PRETTY MUCH ANYTHING.
@a=split(/\n/, `ls -1 EN/snip_*.htm`);
@list=splice(@a,rand(@a),1) while @a;
$temp=`cat $list[0]`;
#print $list[0];
$snippet=&GREPVARS($temp);
return $snippet;
}
sub TABLE_SKEL
{
# EXAMP FOR GENERATING A DYNAMIC HTML TABLE. THE TEMPLATE HTML TABLE IS
SPLIT INTO HEAR, ROWS, FOOT BY STANDARD HTML COMMENT BRACKETS, THIS WAY WE CAN USE
DREAMWEAVER ETC TO EASILY CREATE DYNAMIC TABLE TEMPLATES.
my $tmpid = $_[0];
my $temphtm; my $templine; my $rowcache;

@TABLEDATA=split(/\n/, &FECHALL("SELECT
firstname,lastname,signup_date,subscription_active,id FROM users WHERE
sponsor_id=$tmpid"));

@TABLE=split(/\<\!----\>/, &CAT("EN/rotator_cp_my_refs_table.htm"));

$temphtm=$TABLE[0];

foreach $templine(@TABLEDATA)
{
($tfirstname,$tlastname,$tsignup_date,$tsubscription_active,
$tid)=split(/\|/, $templine);

$turls=&FECHALL("SELECT count(*) FROM rotator WHERE

users_id=$tid AND splash_id = 0");

if ($tsubscription_active == 1) { $tstatus=qq~<font
color=#00FF00><b>PAID</b></font>~; }
else { $tstatus=qq~<font color=#FF0000><b>FREE</b></font>~;
}

$rowcache=$TABLE[1];
$rowcache=~s/\$([a-z0-9_]+)/$$1/gmi;
$temphtm.=$rowcache;
$tmpcount++;
}
$temphtm.=$TABLE[2];

# IF NO REFS FOUND, RETURN NO MEMBERS MSG

if ($tmpcount == 0) { $temphtm=qq~You have not yet referred any new
members.~; }

return $temphtm;
}
sub checkbuffer
{
if ($buffer=~/URL/)
{ $buffer=~/([0-9][0-9]?[0-9]?[0-9]?$)/;
$Fo{'ID'} = $&;
}
}
sub encrypt
{
my $what=shift;
return $what;
$what=~tr/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789@/
DNfeQS5Ouj6rMkIg9PwTXHzC1Vc3vEA8nxlLF7KYbsUmJhZ4WoRqiGpy0aBd2t!/;
$what =~ s/_([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex ($1))/eg;
# return $what;
}
sub unencrypt
{
my $what=shift;
return $what;
$what=~tr/DNfeQS5Ouj6rMkIg9PwTXHzC1Vc3vEA8nxlLF7KYbsUmJhZ4WoRqiGpy0aBd2t!/
abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789@/;
$what =~ s/_([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex ($1))/eg;
# return $what;
}
sub MXCHECK
{
my $list_email=$_[0];
if ($list_email=~/^[\w\._-]+@([\w-]+\.[\w\.]+)/i)
{
#print "checking $domain... ";#!
$status=`host -t mx -W 3 $1`;
$status=~s/\n/ /g;
#print $status."\n";#!
$count++;
if ($status=~/Host .+ not found/)
 { return qq|EMAIL HOST MX ENTRY NOT FOUND|; }
elsif ($status=~/is handled by/)
{ return qq|OK|; }
elsif ($status=~/timed out/)
{ return qq|EMAIL HOST TIME OUT WHILE VERIFYING MX ENTRY|;
}
else { return qq|UNKNOWN RESULT|; }
}
else { return "BAD EMAIL FORMAT !!"; }
}
sub FIXADDRESS
{
$_=$_[0];

s/\.//g;
s/([0-9]+)([a-z])/$1 $2/gi;
s/^([0-9]+) ([NESW])([A-Z0-9]+)/$1 $2 $3/g;
s/([a-z])([A-Z0-9])/$1 $2/g;
s/([^ ])(st|ln|hwy|trl|rd|wa?y|lane|blvd|dr|ct|ave|drive|pl)(a?p?t?|l?
o?t?) ?([a-z]?[0-9]*[a-z]?)$/$1 \L$2\E $3 $4/gi;
s/(p?o?)(box)([0-9]+)/$1 $2 $3/gi;
s/S OUTH/South/gi; s/N ORTH/North/gi; s/E AST/East/gi; s/W EST/West/gi;
s/([0-9]+) (st|nd|rd|th).* (st|ln|hwy|trl|rd|p?a?r?k?wa?y|lane|blvd|dr|
ct|ave|drive|pl) /$1$2 \L$3\E/gi;
s/ +/ /g;s/ +$//g;
s/[^\w%+ -]//g;
s/([A-Z])([A-Z]+)/$1\L$2\E/g;

return $_;
}
sub ARRAY_of_ROWS
{
my $htmlpage = $_[0];
my $cc=0;
my @ARRAY_of_ROWS = ();

@array_of_rows=split(/\<\/tr[^\>]*\>/msi, $htmlpage);

foreach $row (@array_of_rows)

{
$row=~s/[\n\r]+//g;$row=~s/^[\t ]+//g;$row=~s/\t//g;
$row=~/(.*)<tr/i; $tag=$1;

$row_comment="\n<!--======================{ ROW $cc

}========================-->\n";
if ($tag ne "") { push(@ARRAY_of_ROWS, $tbl_comment.$tag);
$row=~s/.*<tr/<tr/gi;}
$row=~s/.*<tr/<tr/gi;
push(@ARRAY_of_ROWS, $col_comment.$row."</tr>");
$cc++;
}
return @ARRAY_of_ROWS;
}
sub ARRAY_of_COLS
{
my $htmlrow = $_[0];
my $cc=0;
my @ARRAY_of_COLS = ();
 @array_of_cols=split(/\<\/td[^\>]*\>/msi, $htmlrow);

foreach $col (@array_of_cols)

{
$col=~s/[\n\r]+//g;$col=~s/^[\t ]+//g;$col=~s/\t//g;
$col=~/(.*)<td/i; $tag=$1;

# $col_comment="\n<!--======================{ ROW $cc

}========================-->\n";
# if ($tag ne "") { push(@ARRAY_of_COLS, $tbl_comment.$tag);
$col=~s/.*<td/<td/gi;}
$col=~s/.*<td/<td/gi;
push(@ARRAY_of_COLS, $col."</td>");
$cc++;
}
return @ARRAY_of_COLS;
}

sub ARRAY_of_TABLES
{
my $htmlpage = $_[0];
my $cc=0;
my @ARRAY_of_TABLES = ();

@array_of_tables=split(/\<\/TABLE\>/msi, $htmlpage);

foreach $table (@array_of_tables)

{
$table=~s/[\n\r]+//g;$table=~s/^[\t ]+//g;$table=~s/\t//g;
$table=~/(.*)<table/i; $tag=$1;

$tbl_comment="\n<!--======================{ TABLE $cc

}========================-->\n";
if ($tag ne "") { push(@ARRAY_of_TABLES, $tbl_comment.$tag);
$table=~s/.*<table/<table/gi;}
$table=~s/.*<table/<table/gi;
push(@ARRAY_of_TABLES, $tbl_comment.$table."</table>");
$cc++;
}
return @ARRAY_of_TABLES;
}
sub TableArray
{
my $url=$_[0];
my $segments=$_[1];
my $tableresultstmp="";

$url=~s~http://~~gi;

if ($url=~/ubpp|ubiee|i-am/)
{ $html=`GET -t 10 "http://$url"`; }
else { $html=&WgetURL($url); }

@ARRAY_of_TABLES=&ARRAY_of_TABLES($html);
if ($segments ne "")
{
@SEGMENTS=split(/,/, $segments);
foreach $seg (@SEGMENTS)
{ $tableresultstmp.=$ARRAY_of_TABLES[$seg]; }
 }
else
{
foreach $table (@ARRAY_of_TABLES)
{ $tableresultstmp.="<br>--------------------------TABLE $cc
------------------<br>".$table; $cc++; }
}
# print "<!-- table results $url : $segments -->";
return $tableresultstmp;
}
sub WgetURL
{
my $AdURL = $_[0];
my $htm="";
my $DLFname="";
my $NewDLFname="";

# strip the http: off the front

$AdURL=~s~http://~~gi;
$AdURL=~/(^.+)\//;
$base=$1;
# get the html page from web with convert links / img option
`wget -o res.tmp -B "$base" "http://$AdURL"`;
# print qq~wget -o res.tmp -B "$base" "$AdURL"~;
# we saves the wget results to res.tmp, now we look for the downloaded
filename found in that
# we let wget name the file what is wants because convert links fails
if the --output-document option is used :( sadly
`cat res.tmp`=~/`([^']+)'/;
$DLFname=$1;
# great now if we got the filename, mv old file 2 new fname and
make new name
# this is done so that after convert images does its work on the file,
the name can be standardised to a format that
# allows other subroutines to see if its there or now, otherwise they
dont know what to look for.
$NewDLFname="wget.tmp";
`mv $DLFname $NewDLFname`;
# whew, now run clean_html or parse_html if option is text , and cat
the new file into a var
#$Fo{'type'} eq "text" ? `html_parse -f $NewDLFname -o $NewDLFname` :
`htmlclean $NewDLFname` ;
$htm=`cat $NewDLFname`;
# now save again to retain grepped changes

return $htm;
}

sub GETGEO
{
# INIT VARS AND PARS
my $ip=$_[0];
%GHASH = ();
`date +%s`;/[0-9]+/;$NOW=$&;

# CHECK TO SEE IF WE ALREADY HAVE THIS IP ON FILE,

$checklocal=&FECHALL("SELECT ip,city,state,country,lat,lon,count FROM GEOTRAX
where ip = '$ip'","yhwh_mp3db");
 # IF SO, INCREMENT COUNT AND RESET TIME, AND RETURN RESULTS
if ($checklocal=~/[0-9]+\.[0-9]+/)
{
&FECHALL("UPDATE GEOTRAX SET count=count+1 , time='$NOW' WHERE ip =
'$ip'","yhwh_mp3db");
return $checklocal."\n";
}
# IF NOT, GO AND FECH THE GEODATA AND ADD TO DB
else
{
$inputhtm=`GET http://netgeo.caida.org/perl/netgeo.cgi?target=$ip`;
@lookup=split(/\n/, $inputhtm);

# AND MAKE KILLER HASH FROM THE HARVEST ... KNOW WHAT I MEAN...?
foreach $line(@lookup)
{ if ($line=~/([A-Z]+): *(.+)<br>/i) { $GHASH{$1}=$2; } }

# OK GEORGE, NOW GO AND TAKE THE STICK TO DADDY, CMON GOTO

DADDY...
&FECHALL("INSERT INTO GEOTRAX
(ip,city,state,country,lat,lon,time,count)
VALUES('$ip','$GHASH{'CITY'}','$GHASH{'STATE'}','$GHASH{'COUNTRY'}','$GHASH{'LAT'}'
,'$GHASH{'LONG'}','$NOW',1)","yhwh_mp3db");

return "$GHASH{'LAT'}|$GHASH{'LONG'}|$GHASH{'CITY'}|$GHASH{'STATE'}|
$GHASH{'COUNTRY'}";
}

}
sub url_encode {
my $rv = shift;
$rv =~ s/([^a-z\d\Q.-_~ \E])/sprintf("%%%2.2X", ord($1))/geix;
$rv =~ tr/ /+/;
return $rv;
}

sub URLencode
{
my $temp=$_[0];

#-------------UPPERCASE CONVERT--------------#

$temp=~s/A/\&\#65/g;$temp=~s/K/\&\#75/g;
$temp=~s/B/\&\#66/g;$temp=~s/L/\&\#76/g;
$temp=~s/C/\&\#67/g;$temp=~s/M/\&\#77/g;
$temp=~s/D/\&\#68/g;$temp=~s/N/\&\#78/g;
$temp=~s/E/\&\#69/g;$temp=~s/O/\&\#79/g;
$temp=~s/F/\&\#70/g;$temp=~s/P/\&\#80/g;
$temp=~s/G/\&\#71/g;$temp=~s/Q/\&\#81/g;
$temp=~s/H/\&\#72/g;$temp=~s/R/\&\#82/g;
$temp=~s/I/\&\#73/g;$temp=~s/S/\&\#83/g;
$temp=~s/J/\&\#74/g;$temp=~s/T/\&\#84/g;
$temp=~s/U/\&\#85/g;$temp=~s/X/\&\#88/g;
$temp=~s/V/\&\#86/g;$temp=~s/Y/\&\#89/g;
$temp=~s/W/\&\#87/g;$temp=~s/Z/\&\#90/g;

#-------------LOWERCASE CONVERT--------------#

$temp=~s/o/\&\#111/g;$temp=~s/a/\&\#97/g;
 $temp=~s/p/\&\#112/g;$temp=~s/b/\&\#98/g;
$temp=~s/q/\&\#113/g;$temp=~s/c/\&\#99/g;
$temp=~s/r/\&\#114/g;$temp=~s/d/\&\#100/g;
$temp=~s/s/\&\#115/g;$temp=~s/e/\&\#101/g;
$temp=~s/t/\&\#116/g;$temp=~s/f/\&\#102/g;
$temp=~s/u/\&\#117/g;$temp=~s/g/\&\#103/g;
$temp=~s/v/\&\#118/g;$temp=~s/h/\&\#104/g;
$temp=~s/w/\&\#119/g;$temp=~s/i/\&\#105/g;
$temp=~s/x/\&\#120/g;$temp=~s/j/\&\#106/g;
$temp=~s/y/\&\#121/g;$temp=~s/k/\&\#107/g;
$temp=~s/z/\&\#122/g;$temp=~s/l/\&\#108/g;
$temp=~s/m/\&\#109/g;

return $temp;
}
sub FECHALL
{
$q = $_[0];
my $DB = $_[1];
my $mode = $_[2];
my $tmpseg = $_[4];
my $delim = $_[5];

my $OO;
$mode=~/file/i ? my $tmpfile = $_[3] : my $tmpcallback = $_[3];
$q=~s/\n//g;
$q=~s/\$(\w+)/$$1/gi;

$OO = `perl -s /var/www/cgi-bin/FechSQL.pl -delim=$delim -

callback=$tmpcallback -file=$tmpfile -seg=$tmpseg -mode=$mode -func=$func -
q=\"$q\" -DB=$DB $vars -remote_ip=$ENV{'REMOTE_ADDR'} -caller=$ENV{'SCRIPT_NAME'}`;
&MYDEBUGLOG($q,$OO);
@SQLCAPT = split(/\n/, $OO);
if ($OO=~/[\n\r]+\w/m)
{ return $OO; }
else { $OO=~s/[\n\r]+//gm;
return $OO;
}
}
sub MYDEBUGLOG
{
$q=shift, if $q eq "";
my $OO=shift, if $OO eq "";
my $tmpEnv = $ENV{'SCRIPT_NAME'};
my $tmpEnv = $ENV{'_'}, if $ENV{'SCRIPT_NAME'} eq "";
$tmpEnv=~s/.+\///gi;
open (OUTF, ">>/var/www/cserv/CMD_HIST_".$tmpEnv.".DAT");
print OUTF "<pre>\n~====================================================~\nQ:
$q\nA:$OO\n</pre>";
close (OUTF);
if ($Fo_showsql eq "on") { print $buff_me_up."\
n~====================================================~\rQ:$q\rA:$OO\r"; }
}
sub SQLVARS_SINGLE
{
$q = $_[0];
$tmpDB = $_[1];
my $prefix = $_[2];
my $mode = "V";
 my @VRECS;
my @vreclines;

$q=~s/[\n\t]+/ /g;
#print "perl -s FechSQL.pl -DB=$DB -mode=$mode -q=\"$q\" -
remote_ip=$ENV{'REMOTE_ADDR'} -caller=$ENV{'SCRIPT_NAME'}\n";
$OO = `perl -s /var/www/cgi-bin/FechSQL.pl -DB=$tmpDB -mode=$mode -q=\"$q\"
-remote_ip=$ENV{'REMOTE_ADDR'} -caller=$ENV{'SCRIPT_NAME'}`;
return "0", if $OO eq "";
@VRECS=split(/^\*+ ([0-9+])\. row \*+/, $OO);
foreach $vrec (@VRECS)
{
@vreclines = split(/[\n\r]+/, $vrec);
$tmpCount++;
foreach $nvpair (@vreclines)
{
($Name,$Value)=split(/: /, $nvpair);
$Name=~s/^[A-Za-z0-9_]+\.//g;
$Name=~s/[^\w]//g;
$NameLen=$Name."Len";
$$NameLen=(length $Value)+1;

if ($Name=~/[a-z]+/i)
{
if ($prefix ne "")
{
$CustomName=$prefix.'_'.$Name;
$$CustomName = $Value,
# push (@$CustomName, $Value);
}
else
{
$$Name = $Value,
# push (@$Name, $Value);
# push (@$VarNames, $Value);
}
}
print "$Name,$$Name - $CustomName,$$CustomName = $Value<br>\
n",if $Fo_showsql eq "on";
}
}
}

sub SQLVARS
{
$q = $_[0];
my $DB = $_[1];
my $prefix = $_[2];
my $append=$_[3];
my $mode = "V", if $_[4] eq "";
my $tmpCount = -1;
my @Names;
my $tmpName;
my $tmpc;
my @VRECS;
my @vreclines;

$q=~s/[\n\t]+/ /g;
 $OO = `perl -s /var/www/cgi-bin/FechSQL.pl -mode=V -q=\"$q\" -DB=$DB -
remote_ip=$ENV{'REMOTE_ADDR'} -caller=$ENV{'SCRIPT_NAME'}`;
#print qq~perl -s FechSQL.pl -mode=$mode -q=\"$q\" -DB=$DB -
remote_ip=$ENV{'REMOTE_ADDR'} -caller=$ENV{'SCRIPT_NAME'}\n~;

@VRECS=split(/\*\*\*\*+.+\*\*\*\*+[\n\r]/, $OO);
if ($mode eq "VC")
{
@COLLATESEQ=COLLATE(3,$#VRECS);
foreach $tmpseqnum (@COLLATESEQ)
{ push(@TMPVRECS, $VREC[$tmpseqnum]); }
@VRECS=@TMPVRECS;
}
foreach $vrec (@VRECS)
{
if ($vrec ne "")
{
$vrec=~s/[a-zA-Z0-9_]+\.([a-zA-Z0-9_]+): /$1: /g;
@vreclines = split(/[\n\r]+/, $vrec);
my @vreclines_unique = do { my %seen; grep { !$seen{$_}++ } sort
@vreclines };
# print "++++++++++++++++++++\n$tmpCount \n$vrec\n+++++++++++++++++
+++\n";
$tmpCount++;
foreach $nvpair (@vreclines_unique)
{
if ($nvpair=~/: /)
{
($Name,$Value)=split(/: /, $nvpair);
warn "warn $Name,$Value,$tmpCount,$#Name\n", if
$Fo_printdebug;
# cut off table name from table.field results
# $Name=~s/^[A-Za-z0-9_]+\.//g;
# replace any non word character with emnpty
$Name=~s/[^\w]//g;
if ($Name=~/[a-z]+/i)
{
push (@Names, $Name), if $tmpCount == 0;
if ($prefix ne "")
{
$CustomName=$prefix.'_'.$Name;
$$CustomName = $Value;
@$CustomName = "", if $tmpCount == 0 &&
$append eq ""; # clear array if this is rec 0
#print " $CustomName,$$CustomName =
$Value<br>\n",if $Fo_showsql eq "on";
$$CustomName[$tmpCount]=$Value;
}
else
{
$$Name = $Value;
@$Name = "", if $tmpCount == 0 && $append
eq "";
$LenName=$Name.'Len';

warn "$Name,$$Name[$tmpCount] = $Value

$tmpCount<br>\n",if $Fo_printdebug eq "on";
$$LenName[$tmpCount]=length $Value;
$$Name[$tmpCount]=$Value;
 if ($#Name > $tmpCount) { print "array
$Name has additional rows. $#Name != $tmpCount ,exiting"; exit; }
if ($tmpCount > 0) { $$Name = ""; $Value
= ""; }
}
}

}
}
}
}
foreach $tmpName (@Names)
{
if ($Fo_printdebug eq "on") { $tmpc=0; foreach $tmpEl (@$tmpName)
{ print "$tmpName , $tmpc, $$tmpName[$tmpc]\n"; $tmpc++; } }
}
&MYDEBUGLOG($q,$OO);
return $tmpCount;
}
sub SQLJSON
{
$q = $_[0];
my $DB = $_[1];
my $prefix = $_[2];
my $objname=$_[3];
my $mode = "V";
my $tmpCount = 0;

$q=~s/[\n\t]+/ /g;

$OO = `perl -s FechSQL.pl -mode=$mode -q=\"$q\" -DB=$DB -

remote_ip=$ENV{'REMOTE_ADDR'} -caller=$ENV{'SCRIPT_NAME'}`;

@VRECS=split(/\*\*\*\*+.+\*\*\*\*+/, $OO);
# $tmpJSON.=qq~{\n\t"$objname": [\n\t~;

foreach $vrec (@VRECS)

{
if ($vrec ne "")
{
# $tmpJSON.=qq~{\n~;
@vreclines = split(/\n/, $vrec);
$tmpCount++;
foreach $nvpair (@vreclines)
{
if ($nvpair=~/: /)
{
($Name,$Value)=split(/: /, $nvpair);
$Name=~s/[^\w]//g;
if ($Name=~/[a-z]+/i)
{
if ($prefix ne "")
{
$CustomName=$prefix.'_'.$Name;
$$CustomName = $Value;
@$CustomName = "", if $tmpCount == 1 &&
$append eq ""; # clear array if this is rec 0
# $tmpJSON.=qq~"$CustomName" : "$Value" ,\
n~;
push (@$CustomName, $Value);
}
else
{
$$Name = $Value;
$Name=~s/^[A-Za-z0-9_]+\.//g;
@$Name = "", if $tmpCount == 1;
# $tmpJSON.=qq~"$Name" : "$Value" ,\n~;
push (@$Name, $Value);
if ($tmpCount > 1) { $$Name = ""; $Value
= ""; }
}
}
}
}
# $tmpJSON.=qq~},\n~;
}
}
#$tmpJSON.=qq~~;
return $tmpJSON;
}

sub GVOICE
{
my $GMAIL = $_[0];
my $GPASS = $_[1];
my $TONUM = $_[2];
my $GMSG = $_[3];

open (OUTGV, "|gvoice -p $GPASS -e $GMAIL");

print OUTGV "s\n";
print OUTGV "$TONUM\n";
print OUTGV $GMSG;
close (OUTGV);
}

sub OUTFILE
{
#writes data to file , onlu 2 modes, default - overwrite file if exists, or
APPEND , add to the bottom of the file if exists.
my $FNAME = $_[0];
my $FDATA = $_[1];
my $FMODE = $_[2];

$FMODE eq "APPEND" ? open (OUTF, ">>$FNAME") : open (OUTF, ">$FNAME");

print OUTF $FDATA;
close (OUTF);
return $FDATA;
}
sub OUTFILE_ONLY
{
# same as OUTFILE but does not return back the data written to STDOUT
my $FNAME = $_[0];
my $FDATA = $_[1];
my $FMODE = $_[2];

$FMODE eq "APPEND" ? open (OUTF, ">>$FNAME") : open (OUTF, ">$FNAME");

print OUTF $FDATA;
 close (OUTF);
}

sub INFILE
{
my $FNAME=$_[0];
my $FileCatch="";

open(INFILE, "$FNAME");
$FileCatch = <INFILE>;
close(INFILE);

return $FileCatch;
}
sub BASH
{
$tmp_cmd=$_[0];
$tmp_mode=$_[1];
warn $tmp_cmd;
if ($tmp_mode eq "system") { SYSTEM(SIMPLEGREP($tmp_cmd)); }
else
{
$grepped_tmp_cmd=SIMPLEGREP($tmp_cmd);
if ($grepped_tmp_cmd ne "")
{
$tmp_cmd_output=`$grepped_tmp_cmd`;
chomp($tmp_cmd_output);
}
return $tmp_cmd;
}

}
sub BINPIPE
{
my $BIN_NAME=$_[0];

open(INBIN, "|$BIN_NAME");
while (<INBIN>)
{
print $_;
$TMP_INPUT.=$_;
}
close(INBIN);
return $TMP_INPUT;
}
sub WAIT
{
$tmpmsg=$_[0];

print $tmpmsg;

while (<>)
{
$tmpi=$_;
# clean carrage returns
chomp($tmpi);
exit, if $tmpi eq "exit";
print "ECHO INPUT: $tmpi\n", if $tmpi=~/echo/;
return $tmpi;
 }
return $tmpi;
}
sub GET_ENV_CONFIG
{
$doysent = `date +%y-%j`;
# create CONFIG hash from sql database
print "$ENV{'SCRIPT_NAME'} \| READY...\n", if $debug==1;
@TMP=split(/\n/, &FECHALL("SELECT var,val FROM SETTINGS where
script='$ENV{'SCRIPT_NAME'}' OR script='all'","P"));
for (@TMP)
{
($Name,$Value)=split(/\|/, $_);
$CONFIG{$Name} = $Value;
print "CONFIG{'$Name'}=$Value;\n",if $debug==1;
}
}
sub CheckReferer {

$Approve=$_[0];

if (defined $ENV{'HTTP_REFERER'}) {
foreach $Referer (@Referers) {
if ($ENV{'HTTP_REFERER'} =~ /.*$Approve.*/i) {
return;
}
}
}
print &RefererError("Unauthorized access to: $ENV{'HTTP_REFERER'}",1);
}
sub sendmail
{

# return;

$u_name = $_[0];
$u_email = $_[1];
$subject = $_[2];
$MPage = $_[3];

$mailprogram = "/usr/lib/sendmail -t";

my $type = qq!Mime-Version: 1.0\nContent-Type: text/html; charset="us-
ascii"\n!;
open (MAIL, "|$mailprogram") || die "Can't open $mailprogram!\n";
print MAIL "To: $u_name <$u_email>\n";
print MAIL "From: UBIE-E-MAIL ADMIN <ubie-e-mail\@a-url.com>\
n";
print MAIL "Subject: $subject\n";
print MAIL "${type}\n";
print MAIL "$MPage\n";
close(MAIL);
}
sub RefererError {
my($ErrorText, $Exit) = @_;
print "Content-type: text/plain\n\n \n";
print "<HTML><HEAD></HEAD><BODY>$ErrorText</BODY></HTML>\n";
if($Exit) { exit; }
}
sub F2SQL
{
my $F2SQL_TEMPLATE=$_[0];

# CHECK TO SEE IF THIS IS A DUPLICATE RUN THROUGH ON THE SAME TEMPLATE !

# if ($F2SQL_TEMPLATE eq $F2SQL_TEMP_HOLDER) {$F2SQL_TEMPLATE=""; return; }
# else { $F2SQL_TEMP_HOLDER=$F2SQL_TEMPLATE; }

$Fo{'db'} ne "" && $Fo{'DB'} eq "" ? $Fo{'DB'}=$Fo{'db'} : // ;

$Fo{'delim'} eq "" ? $Fo{'delim'}="\|" : // ;

# if ($F2SQL_TEMPLATE eq "")
# { $F2SQL_TEMPLATE=`cat
/home/ubieepil/public_html/HTM/TEST2cgi_$Fo{'TMPL'}.htm`; }

if ($Fo{'ADDQUERY'} ne "")
{
print "\nADDING $addquery\...\n";
F2SQL_FECH("REPLACE INTO QUERYS VALUES
('$Fo{'USER'}','$Fo{'CLASS'}','$Fo{'ADDQUERY'}','$Fo{'QUERY'}','$Fo{'DATABASE'}','$
Fo{'MODE'}','$Fo{'NOTES'}')","P");
print F2SQL_FECH("SELECT * FROM QUERYS WHERE keyword LIKE
'$Fo{'ADDQUERY'}'","P","H");
exit;
}

if ($Fo{'q'} ne "")
{
#print $Fo{'q'};#!
$F2SQL_STDOUT.=F2SQL_SHORTHAND($Fo{'q'})."\n", if $Fo{'showquery'}
eq "1";

$F2SQL_QQQ=&F2SQL_FECH(F2SQL_SHORTHAND($Fo{'q'}),$Fo{'DB'},
$Fo{'mode'});
return $F2SQL_STDOUT.&F2SQL_PREPBODY($F2SQL_TEMPLATE);

}
elsif ($Fo{'keyword'} ne "")
{
@F2SQL_QQue=split(/\n/, &F2SQL_FECH("SELECT query,db,mode,notes
FROM QUERYS WHERE user LIKE '$Fo{'user'}\%' AND class LIKE '$Fo{'class'}' AND
keyword LIKE '$Fo{'keyword'}'"));
#print qq|SELECT query,db,mode,notes FROM QUERYS WHERE\nuser LIKE
'$Fo{'user'}\%'\nAND class LIKE '$Fo{'class'}'\nAND keyword LIKE '$Fo{'keyword'}'\
n|;#!
foreach $F2SQL_ENTRY(@F2SQL_QQue)
{
($q,$F2SQL_DB,$F2SQL_mode,$F2SQL_notes)= split(/\|/,
$F2SQL_ENTRY);
$q=~s/\$X/$Fo{'X'}/g;
$q=~s/\$Y/$Fo{'Y'}/g;
$q=~s/\$Z/$Fo{'Z'}/g;
$q=~s/\$(\w+)/$Fo{$1}/g;

$F2SQL_STDOUT.="-- notes --\n$F2SQL_notes", if

$Fo{'shownotes'}==1;
$F2SQL_STDOUT.="-- query --\n$q", if $Fo{'showquery'}==1;

if ($Fo{'TMPL'} eq "")
{ return F2SQL_STDOUT.F2SQL_FECH(F2SQL_SHORTHAND($q),
$F2SQL_DB,$F2SQL_mode); }
else
{ $F2SQL_QQQ=F2SQL_FECH(F2SQL_SHORTHAND($q),$F2SQL_DB,
$F2SQL_mode);
return &F2SQL_PREPBODY($F2SQL_TEMPLATE);
}
}
}

else { return &F2SQL_PREPBODY($F2SQL_TEMPLATE); }

}

#>->->->->->->->->->->->->->->->->->->->->->->-!>=- F2SQL -=<#<-<-<-<-<-<-<-<-<-<-

<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-
<-<-<-#!

sub F2SQL_PREPBODY
{

my $F2SQL_BODY=$_[0];
my $F2SQL_OUTBODY="";

# return "", if $onerun == 1;

# $onerun=1;

if ($F2SQL_QQQ=~/^.+[\|,].+[\|,]/ && $Fo{'WRAP'} ne "NONE")

{ $temp=$F2SQL_QQQ; $F2SQL_QQQ=qq|<pre>$temp</pre>|; }
elsif ($F2SQL_QQQ=~/\*\*\*.+[0-9]+.+\*\*\*/ && $Fo{'WRAP'} ne "NONE")
{ $temp=$F2SQL_QQQ; $F2SQL_QQQ=qq|<pre>$temp</pre>|; }

# $image1 = &RNDIMG("","FGSHUFF");
# $image2 = &RNDIMG("$image1");

# $F2SQL_BODY =~s/3d.*dol[^"]*jpg/BGSHUFF\/$image2/gi, if $Fo{'AFFID'} eq "";

# $F2SQL_BODY =~s/flyingmoney[a-z_\.]+/FGSHUFF\/$image1/gi,if $Fo{'AFFID'} eq
"";

@F2SQL_BOD=split(/[\n]/, $F2SQL_BODY);

foreach $F2SQL_line(@F2SQL_BOD)
{

#<-- look for table params to insert into next table , if next result
is a table!
if ($F2SQL_line=~/\<\!--table(.+)--\>/)
{
$F2SQL_TABLE_VALS=$1;
#print "found table vals $F2SQL_TABLE_VALS\n";
}
if ($F2SQL_line=~/\<\!--font(.+)--\>/)
{
$F2SQL_FONT_VALS=$1;
#print "found font vals $F2SQL_FONT_VALS\n";
}
# $F2SQL_line=~/\<\!--rows(.+)--\>/; #<-- look for table params to
insert into next table rows, if next result is a table!
# $F2SQL_ROW_VALS=$1;

#<-- find and replace variables defined by **varname and replase with
varnames form submission, unless the line is the 'q' query for the F2SQL form
(usually on the template if present) , because thoes **varnames are replaced AFTER
the form submission but BEFORE the template result page is printed they are 'reset'
, by excluding those **varnames below, whew! god help us all!!
if ($F2SQL_line=~/name.+['"]q['"].+value/i){}
else { $F2SQL_line=~s/\*\*(\w+)/$Fo{$1}/gi; }

$F2SQL_line=~s/\[\[QQQ\]\]/$F2SQL_QQQ/gi;

$F2SQL_RES=&F2SQL_GETRES($1), if $F2SQL_line=~/\<?\!?\-?-?\[\[([^\]]
+)\]\]\-?\-?\>?/;
$F2SQL_RES=&F2SQL_GETRES($1), if $F2SQL_line=~/\<option\[\[([^\]]
+)\]\]option\>/;
$F2SQL_RES=~s/TABLE BORDER\=1/TABLE $F2SQL_TABLE_VALS/g;
# $F2SQL_RES=~s/\<TR\>/<TR $F2SQL_ROW_VALS>/g;
$F2SQL_RES=~s/TD\>([^\<]+)\<\/TD/TD><font
$F2SQL_FONT_VALS>$1<\/font><\/TD/g;
#print qq|<!-- GOT BACK $F2SQL_RES -->|;
$F2SQL_line=~s/\<?\!?\-?-?o?p?t?i?o?n?[^\[]+\[\[([^\]]+)\]\][^\]]+o?p?
t?i?o?n?\-?\-?\>?/$F2SQL_RES/g;
#print qq~<!-- $F2SQL_line -->~;
$F2SQL_OUTBODY=$F2SQL_OUTBODY.$F2SQL_line."\n";
}
return $F2SQL_OUTBODY;
}

#>->->->->->->->->->->->->->->->->->->->->->->-!>=- F2SQL -=<#<-<-<-<-<-<-<-<-<-<-

<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-
<-<-<-#!
# LOOKS IN QUERYS TABLE FOR KEYWORD AND OPTIONAL VALUE PARAMS, TAKES ONE
ARGUMENT IN THE FORM OF
# "$KEYWORD|$X|$Y|$Z" , RUNS QUERY VIA FechSQL.pl AT THE SYSTEM COMMAND LINE,
CHECKS CONDITIONS OF
# RETURN DATA FROM THE QUERY, AND RETURNS THE APPROPRIATE RESULTS.
#!
sub F2SQL_GETRES
{
$F2SQL_VALS=$_[0];

#print "\n<!-- PASSTHROUGH $ccc -->\n";

($F2SQL_ikeyword,$X,$Y,$Z)=split(/[\!\|]/, $F2SQL_VALS);
&COMMENT("SQL TAG LOOKUP ($F2SQL_ikeyword,$X,$Y,$Z)");
$F2SQL_Result=`perl -s FechSQL.pl "$F2SQL_ikeyword" "$X" "$Y" "$Z"`;

# CHECK TO SEE IF THIS IS A DUPLICATE RESULT PER THIS SESSION !

if ($F2SQL_Result eq $F2SQL_Result_HOLD && $F2SQL_ikeyword eq
$F2SQL_ikeyword_HOLD) { $F2SQL_Result=""; return; }
else { $F2SQL_Result_HOLD=$F2SQL_Result;
$F2SQL_ikeyword_HOLD=$F2SQL_ikeyword; }

# IF KEYWORD,USER OR CLASS COLUMNS IN THE QUERYS TABLE CONTAINS THE STRING

OPTLIST, RETURN #!
# THE OUTPUT IN THE FORM OF AN HTML FORM OPTION LIST, ALLOWING FOR DYNAMIC
FORM FIELDS. #!

if ($F2SQL_ikeyword=~/OPTLIST/i)
{
@F2SQL_OOO=split(/\n/, $F2SQL_Result);
$F2SQL_Result="";
foreach $F2SQL_pair(@F2SQL_OOO)
{
@F2SQL_VAL=split(/\|/, $F2SQL_pair);

# IF RESULT LOOKS LIKE A PULL DOWN OPTION BOX COLUMN LIST, MAKE
VAL[1]=VAL[0] #!

if ($F2SQL_VAL[1]=~/^[a-z]+\([0-9]+\)/)
{ $F2SQL_Result=$F2SQL_Result.qq|<option
value="$F2SQL_VAL[0]">$F2SQL_VAL[0]</option>\n|; }
else
{ $F2SQL_Result=$F2SQL_Result.qq|<option
value="$F2SQL_VAL[0]">$F2SQL_VAL[1]</option>\n|; }
}
return $F2SQL_Result;
}
# IF RESULT IS A TABLE, STRIP THE TOP <TH></TH> ROW AND REPLACE IT
elsif ($F2SQL_Result=~/\<table/i)
{
$F2SQL_Result=~s~<tr><th>.+</th></tr>~~gi;
return $F2SQL_Result;
}
elsif ($F2SQL_Result=~/[\|,]/) { return "<pre>".$F2SQL_Result."</pre>"; }
else { return $F2SQL_Result; }
}

#>->->->->->->->->->->->->->->->->->->->->->->-!>=- F2SQL -=<#<-<-<-<-<-<-<-<-<-<-

<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-
<-<-<-#!

sub F2SQL_FECH
{
$q = $_[0];
$DB = $_[1];
$mode = $_[2];

$q=~s/\n//g;

$OO = `perl -s FechSQL.pl -DB=$DB -mode=$mode -q=\"$q\" -

remote_ip=$ENV{'REMOTE_ADDR'} -caller=$ENV{'SCRIPT_NAME'}`;

print "\n~====================================================~\nQ:$q\nA:$OO\
n", if $showsql ne "" || $Fo{'showsql'} ne '';
}
1;