#!/usr/local/bin/perl
 # This Software Package is copyrighted and the SOLE OWNERSHIP is
 # (c) 1997 - 2000  DragonWare Internet Solutions Corp. ALL RIGHTS RESERVED
 #
 # You may freely copy and distribute this software so long
 # as all documentation and this notice is included.
 #
 # If you wish to modify and distribute this software, feel free.
 # You MAY NOT charge for distributing it. If you modify it,
 # please make sure you document it (and if it is a good hack
 # let me know - I might include it in a future release).chris@zarahemla.com
 #
 # The most current release can always be found at
 # <URL:http://www.zarahemla.com/~chris/gnu/>
 #
 #                                  SOFTWARE WARRANTY AND DISCLAIMER
 #
 #DragonWare Internet Solutions Corp. makes no warranty of any kind, either express or implied
 #with respect to the design or use of this software package.  This software package provided
 #hereunder is provided "as is", and all warranties, express or implied including but not limited
 # to implied warranties of merchantability and fitness for a particular purpose are expressly
 # disclaimed.  There is no guarantee that the operation of the software package will be error 
 #free.  USER assumes any and all risk as the the results and the performance of this software
 #package.  In no event shall DragonWare Internet Solutions Corp. be held liable for any loss, 
 #expenses, or damages of any kind, whether such damages are direct, indirect, incidental or 
 #consequential arising in any manner from the use of the software package or any portion 
 #thereof.  
 # 
 ############################################################
 #VERSION 2.0956

 # This is the initalization routine for the cgi it creates a set of varables 
 # that are global relating to dates and times and the http server name

 ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time);
 $month =(Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec)[$mon];
 $DATE= `date +%b/%d/%y`;
 $year =`date +%Y`;
 $time =`date +%r`;
 $date =`date +%b/%d/%Y`;
 $LDATE=$date;
 $pgdate=`date +%m-%d-%Y`;
 chomp ($pgdate);
 chomp ($year);
 chomp ($time);
 chomp ($date);
 chomp ($LDATE);
 chomp ($DATE);

 $CGI_SERVER=$ENV{'SERVER_NAME'};



##########################################
## file locking routines version 1
## one pram is passed the path to the lock file "/fo/bar/file.lock"
## this routine UNLOCKS the file
## returns 1 if successfull a 0 if not
##########################################
 sub unlockFile{
   my ($lockpath)=@_;
     
   unlink("$lockpath")||return(0);
   return (1);
 }

##########################################
## file locking routines version 1
## 2 prams are passed the 
## path to the lock file "/fo/bar/file.lock"
## optional seconds to wait for a lock (default 30) "25"
## this routine returns a 0 if the file is already locked and no lock was possable 
## in $lockWait seconds
## 1 is returned if the lock was successfull
## -1 is returned if a file error prevented the creation of the lock
##########################################
 sub lockFile {
  my ($lockpath,$lockWait)=@_;
   if (!$lockWait){$lockWait=30;}
   my   $lockCount = 0;
   while (-f "$lockpath") { 
     if ($lockCount > $lockWait) {
       return 0;             
     }
     sleep 1; 
     $lockCount++;
   }

   open(LOCK,">$lockpath") || return(-1);
   close (LOCK);
   return (1);
 }

##########################################
## file locking routines version 2
## 4 prams are passed the 
## path to the lock file "/fo/bar/file"
## seconds to wait for a lock  "25"
## 
## this routine returns a 0 if the file is already locked and no lock was possable 
## in $lockWait seconds
## 1 is returned if the lock was successfull
## -1 is returned if a file error prevented the creation of the lock
##########################################
sub slock{
   my($filename,
      $lockwait,
      $lockinterval,
      $lockcount)=@_;
   chomp($filename);
  
   
   $filename.=".lock";
   
   if (($lockwait eq "") || ($lockwait <= 1))
     {
       $lockwait=30;
     }
   if (($lockinterval eq "") || ($lockinterval <= 1))
     {
       $lockinterval=1;
     }
   
   $lockcount=0;
   
   while (-f "$filename")
     {
       if ($lockcount > $lockwait)
	 {
	   $lockcount=0;
	   return(0);
	 }
       sleep($lockinterval);
       $lockcount=$lockcount+$lockinterval;
     }
   open(LOCK,">$filename") || return(0);
   close(LOCK);
   return(1);
 }
 

 sub sunlock{
   my($filename)=@_;
   my ($count)=0;
   chomp($filename);
   $filename.=".lock";
   while (-f $filename)
     {
       unlink("$filename");
       $count++;
       if ($count >= 30)
	 {
	   print("\n***ERROR: unable to unlock $filename\n\n");
	   die "\n";
	 }
     }
 }




##########################################
## CGI GET POST and Shell pram reader version 1
## all prams are ruturned in %FORM 
##
##########################################
 sub readForm{
   # Get the POST method input
  my @pairs, $pair, $buffer, $name, $value, %COUNT;
  read(STDIN, $Query_String, $ENV{'CONTENT_LENGTH'});
   #GET method
   $Query_String=$Query_String."&$ENV{'QUERY_STRING'}&";
   #COMMAND LINE method
   if ($ARGV[0]){$Query_String=$Query_String.$ARGV[0];}
   
   $buffer=$Query_String;
   # Split the name-value pairs
   @pairs = split(/&/, $Query_String);

   # Make the $FORM array
   foreach $pair (@pairs){
     my ($name, $value) = split(/=/, $pair);
     $name =~ tr/+/ /;
     $name =~ s/\;//g; #fix windows MSIE bug
     $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
     $value =~ tr/+/ /;
     $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
     if ( defined $name && $name ne '' ) {
       $FORM{$name} = $value;
     }
   }
 return (%FORM);
 }


##########################################
## CGI GET POST and Shell pram reader version 2
## all prams are ruturned in %FORM  some may be in the form of $FORM{name}=@name
## and as global scalers of $name=value or @name=(val.....)
## the global $Query_String contains un corrected pram string
##########################################
 sub readForm2{
 # readForm2 gets no parameters by default,
 my @pairs, $pair, $buffer, $name, $value, %COUNT;
 # Get the POST method input
 if(!$Query_String){
   read(STDIN, $Query_String, $ENV{'CONTENT_LENGTH'});
   # Get the GET method input
   $Query_String=$Query_String."&$ENV{'QUERY_STRING'}&";
   # command line method
   if ($ARGV[0]){$Query_String=$Query_String.$ARGV[0];}
 }


 # Split the name-value pairs
 $buffer=$Query_String;
 @pairs = split(/&/, $Query_String);

 # Make the $FORM array
 foreach $pair (@pairs){
   ($name, $value) = split(/=/, $pair);
   $name =~ tr/+/ /;
   $name =~ s/\;//g; #fix windows MSIE bug
   $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
   $value =~ tr/+/ /;
   $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;


   #assign value to dereferenced varable or array if more than one value
   if ($value ne '' and $name ne '') {
     if (! defined $$name){
       $COUNT{$name} = 0;
       $$name[0]=$value;
       $$name=$value;
     } else{
       $COUNT{$name}++;
       $$name[$COUNT{$name}] =$value;
     }
   }
 }
 foreach my $key ( keys %COUNT ) {
   if ( $COUNT{ $key } eq 0 ) {
     $FORM{$key} = $$key;
   } else {
     $FORM{$key} = \@$key;
   }
 }
 return (%FORM);
}


#############################
## preforms a hex escape on a HASH of values
## pass the %HASH to the routine
## returns quanity of hases changed and the changed hash
#############################
 sub escape_all {
   my (%FORM)=@_;
   my $count=0;
   foreach $key (%FORM){ 
     $count++;  
     $FORM{$key} =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
   }
   return ($count,%FORM);
 }




############################
## removes tab chars from a HASH of values
## pass the %HASH to the routine
## returns the changed hash
#############################
 sub deTab{
   my (%FORM)=@_;
   my $key;
   foreach $key (sort keys(%FORM)) {
     if($FORM{$key}){
       $FORM{$key} =~ s/\t/$1/g;
     } 
   }
   return (%FORM);
 }


############################
## all CR chars in a string
## pass the $value to the routine
## returns  the changed value
#############################
 sub killCr{
   my ($killit) =@_;
   $killit  =~ s/(.\n)//g;
   return($killit);
 }


############################
## preforms a html escape for CR on a HASH of values
## pass the %HASH to the routine
## returns  the changed hash
#############################
 sub dereturn{
   my $key;
   my (%FORM)=@_;
   foreach $key (sort keys(%FORM)) {
     if($FORM{$key})
       {
	 $FORM{$key} =~ s/(.\n)/<br>/g;
	 
       }
   }
   return (%FORM);
 }

############################
## preforms a html escape on a passed value
## pass the $value to the routine
## returns  the changed string
#############################
 sub escape2{
   my($toencode) = @_;   
   $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
   return $toencode;
 }


############################
## Finds the browser name and version of the current browser
## returns the browser name and version
#############################
 sub sniff {
   # Exported sub to check browser versions.
   # Mozilla and IE friendly.  We can even spot the IE/AOL mess.
   #
   $self = @_;
   $ua = $ENV{HTTP_USER_AGENT};
   # Make it CLI/passed param friendly for testing.
   $ua ||= shift;
   if ($ua =~ /Mozilla/) {
     &ns_ver;
     
     
     if ($ver >= 4) {
       if ($ua =~ /MSIE/) {
	 $navtype = $ua;
	 $navtype =~ s/.*\(//;
	 $navtype =~ s/\).*//;
	 @nav = split(/;/, $navtype);
	 for ($i = 0 ; $i<=$#nav ; $i++){
	   $nav[$i] =~ s/^\s//;
	   $nav[$i] =~ s/\s$//;
	 }
	 $msie = $nav[1];
	 $msie =~ s/^MSIE //;
	 return("msie $msie");
       }
       $navtype = &ns4_type;
       $navtype =~ tr/A-Z/a-z/;
       return("$navtype $ver");
     } elsif ($ver >= 3) {
       if ($ua =~ /Opera/) {
	 $navtype = $ua;
	 $navtype =~ s/.*\(//;
	 $navtype =~ s/\).*//;
	 @nav = split(/;/, $navtype);
	 for ($i = 0 ; $i<=$#nav ; $i++){
	   $nav[$i] =~ s/^\s//;
	   $nav[$i] =~ s/\s$//;
	 }
	 $_ = $nav[1];
	 /Opera\//;
	 $opera = $';
	 return("opera $opera");
       } else {
	 return("navigator $ver");
       }
     } elsif ($ver >= 2) {
       if ($ua =~ /MSIE/) {
	 $navtype = $ua;
	 $navtype =~ s/.*\(//;
	 $navtype =~ s/\).*//;
	 @nav = split(/;/, $navtype);
	 for ($i = 0 ; $i<=$#nav ; $i++){
	   $nav[$i] =~ s/^\s//;
	   $nav[$i] =~ s/\s$//;
	 }
	 $msie = $nav[1];
	 $msie =~ s/^MSIE //;
	 if ($ua =~ /AOL/) {
	   return("msie $msie AOL");
	 } else {
	   return("msie $msie");
	 }
       } else {
	 return("navigator $ver $ua");
       }
     }
   } else {
     # Yeesh.  I need to get some other browsers in here.
     return("other $ua");
   }
   
 }
 
 sub ns_ver {
   # Internal sub to rip out the Mozilla version number.
   $ver =  $ENV{HTTP_USER_AGENT};
   $ver =~ s/Mozilla\///;
   $ver =~ s/\s.*//;
   return($ver);
 }
 
 sub ns4_type {
   # Figure out if it's Navigator 4.x or Communicator 4.x
   $navtype =  $ENV{HTTP_USER_AGENT};
   $navtype =~ s/.*\(//;
   $navtype =~ s/\).*//;
   @nav = split(/;/, $navtype);
   for ($i = 0 ; $i<=$#nav ; $i++){
     $nav[$i] =~ s/^\s//;
     $nav[$i] =~ s/\s$//;
   }
   if ($nav[2] =~ /Nav/) {
     $navtype="navigator";
   } else {
     $navtype="communicator";
   }
   return("$navtype");  
   
 }

 

 1;