#!/usr/bin/perl
####################################################################
# Script:       | Password Manager                                 #
# Version:      | 2.2                                              #
# By:           | i2 Services, Inc. / CGI World                    #
# Web Site:     | http://www.cgi-world.com                         #
# Copyright:    | CGI World of i2-Services, Inc.                   #
# Released:     | September 29th 2004                              #
# Updated:      | October 18th, 2005                               #
####################################################################
# By using this software, you have agreed to the license           #
# agreement packaged with this program. i2-Services, Inc           #
# (CGI-World.Com) reserves the right to track this license.        #
#                                                                  #
####################################################################

$subscribe_file = "subscribe.html";

# Subscribe / Create account Template file name.


####################################################################
# DO NOT EDIT BELOW THIS LINE
####################################################################
































%Global    = ("cgidir"    => $0=~m#^(.*)[\\/]#?$1:(`pwd`=~/(.*)/)[0],	# script directory
	          "cgiurl"    => (split("/",$ENV{'SCRIPT_NAME'}))[-1],	# script url
	          "sendmail"  => "/usr/sbin/sendmail",			# sendmail
	      );

$cgidir = "$Global{'cgidir'}";
$custom_count = 20;

$SIG{__DIE__} = $SIG{__WARN__} = \&HTML_Error;				# show error msg on die/warn
srand(time^($$+($$<<15)));						# Set Random Number Seed
$|++;									# Unbuffer output



### Display Image

if($ENV{'QUERY_STRING'} =~ /.gif|.jpg^/gi) {$image = "$ENV{'QUERY_STRING'}"; &Display_Image; exit };

### Database Definitions

%SetupDB   = ("datafile" => "prog_files/setup.dat",
	      "filelock" => "prog_files/setup.lock",
	      "fields"   => [qw(num login_timeout login_id login_pw mailprog mailprog_location admin_email mail_server cp_url last_update company update_time action default_length default_renew exp_warning default_groups default_no_exp admin_url dup_email wait_time send_number)],
	      "backup"   => "disabled",
	      "cgiext"   => ".cgi");

%AccountsDB     = ("datafile" => "prog_files/accounts.dat",
	              "filelock" => "prog_files/accounts.lock",
	              "fields"   => [qw(num full_name email username password created modified account_length renew_length no_expiration sub_groups expires_date extra extra extra extra extra extra extra extra extra extra FIELD1 FIELD2 FIELD3 FIELD4 FIELD5 FIELD6 FIELD7 FIELD8 FIELD9 FIELD10 FIELD11 FIELD12 FIELD13 FIELD14 FIELD15 FIELD16 FIELD17 FIELD18 FIELD19 FIELD20)],
	              "backup"   => "monthly",
	              "cgiext"   => ".cgi");

%ApprovalsDB     = ("datafile" => "prog_files/approvals.dat",
	              "filelock" => "prog_files/approvals.lock",
	              "fields"   => [qw(num full_name email username password created modified account_length renew_length no_expiration sub_groups expires_date extra extra extra extra extra extra extra extra extra extra FIELD1 FIELD2 FIELD3 FIELD4 FIELD5 FIELD6 FIELD7 FIELD8 FIELD9 FIELD10 FIELD11 FIELD12 FIELD13 FIELD14 FIELD15 FIELD16 FIELD17 FIELD18 FIELD19 FIELD20)],
	              "backup"   => "monthly",
	              "cgiext"   => ".cgi");


%InactivesDB     = ("datafile" => "prog_files/inactives.dat",
	              "filelock" => "prog_files/inactives.lock",
	              "fields"   => [qw(num full_name email username password created modified account_length renew_length no_expiration sub_groups expires_date extra extra extra extra extra extra extra extra extra extra FIELD1 FIELD2 FIELD3 FIELD4 FIELD5 FIELD6 FIELD7 FIELD8 FIELD9 FIELD10 FIELD11 FIELD12 FIELD13 FIELD14 FIELD15 FIELD16 FIELD17 FIELD18 FIELD19 FIELD20)],
	              "backup"   => "monthly",
	              "cgiext"   => ".cgi");


%CustomsDB     = ("datafile" => "prog_files/customs.dat",
	              "filelock" => "prog_files/customs.lock",
	              "fields"   => [qw(num sort type question answers required viewable editable searchable)],
	              "backup"   => "monthly",
	              "cgiext"   => ".cgi");



@mon	= qw(Null Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
@month	= qw(Null January February March April May June July August September October November December);

# ----------------------------------------------------------------------------
# Main : Test conditions and give commands
# ----------------------------------------------------------------------------


  ### Files & Directories:

  &DB_Load(\%SetupDB, \%setup, 1);				# Load Setup Options



  $Global{'today'} = int(time / 86400);

  $todays_date = &DateString("March 3rd, 1999",time());

  if($setup{'last_update'} ne "$todays_date") {
     &Cycle_Data;    
  }
  


  %in  = &ReadForm;						# Read CGI Form input
  %ck  = &ReadCookie;						# Load Browser Cookies


  

  ### Define Global Vars

  ### Create
  if($in{'save_form'}) 		 { &Save_Form;	      }		
  if($in{'add_user'})        { &Create_Account;   }	

  &Create_Account;

  exit;



# ------------------------------------------------------------------------ 
# Function    : Save Form
# Description : Same / Update Form
#
# Usage	      : &Save_Form;
# Arguments   : none
# ------------------------------------------------------------------------ 

sub Save_Form {

     # Check for General Errors
     
     if(!$in{'full_name'}) { $in{'error'} .= "<li> Required: Your Name<br>";  }
     if(!$in{'username'} || $in{'username'} =~ s/[^A-Za-z0-9\.\-\_\@]//igs) { 
        $in{'error'} .= "<li> Username Not Correct Format<br>";
     }
     if(!$in{'password'}) { $in{'error'} .= "<li> Required: Password<br>";  }

     if(!$in{'email'} || $in{'email'} !~ /.*\@.*\..*/) {
        $in{'error'} .= "<li> e-Mail Address Not Correct Format<br>";
     }

     if($in{'no_expiration'}) { $in{'no_exp_checked'} = " checked" };


     $rowcode  = sub {

        if($customs{'viewable'} && $customs{'required'} && $customs{'question'} && !$in{"FIELD$customs{'num'}"}) {
           $in{'error'} .= "<li> Required: $customs{'question'}<br>";
        }            
     };

     ### Database Sort Order

     $sortcode = sub {
        $value_a    = (split(/\¡/,$a))[1];
        $value_b    = (split(/\¡/,$b))[1];
        lc($value_b) <=> lc($value_a);
    };   
  

     &DB_List(\%CustomsDB, $rowcode, $sortcode, \%customs);
 



     ##########################

     ### Check if e-Mail or Username is in Active Use
     ############################################################

     $rowcode  = sub {
 
        if($in{'username'} =~ /^$accounts{'username'}$/i && $accounts{'username'} !~ /^$in{'user'}$/i) {
         $in{'error'} .= "<li> Username is Already in Use<br>";
         $in{'username'} = $in{'user'};

       }

        if($setup{'dup_email'} && $in{'email'} =~ /^$accounts{'email'}$/i && !$email_found) {
         $in{'error'} .= "<li> e-Mail Address Already on File<br>";
         $email_found = 1;
       }
     };
 
     &DB_List(\%AccountsDB, $rowcode, $sortcode, \%accounts);



     ### Check if e-Mail or Username is in Approval Database
     ############################################################
     $rowcode  = sub {
 
        if($in{'username'} =~ /^$accounts{'username'}$/i && $accounts{'username'} !~ /^$in{'user'}$/i) {
         $in{'error'} .= "<li> Username is Already in Use<br>";
         $in{'username'} = $in{'user'};

       }

        if($setup{'dup_email'} && $in{'email'} =~ /^$accounts{'email'}$/i && !$email_found) {
         $in{'error'} .= "<li> e-Mail Address Already on File<br>";
         $email_found = 1;
       }
     };
 
     &DB_List(\%ApprovalsDB, $rowcode, $sortcode, \%accounts);


     ### Check if e-Mail or Username is in Inactive Database
     ############################################################
     $rowcode  = sub {
 
        if($in{'username'} =~ /^$accounts{'username'}$/i && $accounts{'username'} !~ /^$in{'user'}$/i) {
         $in{'error'} .= "<li> Username is Already in Use<br>";
         $in{'username'} = $in{'user'};

       }

        if($setup{'dup_email'} && $in{'email'} =~ /^$accounts{'email'}$/i && !$email_found) {
         $in{'error'} .= "<li> e-Mail Address Already on File<br>";
         $email_found = 1;
       }
     };
 
     &DB_List(\%InactivesDB, $rowcode, $sortcode, \%accounts);



      ##########################


     # If Erorrs, Go Back to Setup New Form
     if($in{'error'}) {

        if($in{'edit'}) {
           $in{'num'} = $in{'edit'};
           &Modify_Account;
        }

        else {

           &Create_Account;
        }
     }
 


     # ADD NEW ACCOUNT
     ################################################################

       for(1.. $custom_count) {
          if($two{"FIELD$_"}) { 
              $in{"FIELD$_"} = $multiples{"FIELD$_"};
           }
       }

        
       # Auto Activate New Account:
       ###########################################################
 
       if($setup{'action'} eq "activate") {

        $in{'modified'} = &DateString("March 3rd, 1999 - HH:MM:SS",time());
        $in{'created'} = &DateString("March 3rd, 1999 - HH:MM:SS",time());

        $in{'account_length'} = $in{'account_length'} || $setup{'default_length'};
        $in{'renew_length'} = $in{'renew_length'} || $setup{'default_renew'};
        $in{'sub_groups'} = $in{'sub_groups'} || $setup{'default_groups'};


        $today = int(time / 86400);
        $exp_date = time + 86400 * $in{'account_length'};

        ($sec,$min,$hour,$mday2,$month,$year2) = localtime($exp_date);
        $month++;
        $year2 += 1900;

        if($mday2 < 10) { $mday2 = "0$mday2" };

        $in{'expires_date'} = "$month[$month] $mday2, $year2";
 
        if($setup{'default_no_exp'} || $in{'no_exp'}) { 
           $in{'expires_date'} = "No Expiration";
           $in{'no_expiration'} = "No Expiration";

        }

        if($in{'account_length'} && int($in{'account_length'})) { 
          $in{'account_length'} += $today;
       }


          $in{'num'} = &DB_Add(\%AccountsDB, \%in);

          &Send_Email('account_created');

          print "Content-Type:text/html\n\n";
          print &Template("interface/thanks.html",\%in);

          &Cycle_Passwords;


          exit;

       }

       # Account Needs to be Approved:
       ###########################################################

       else {


        $in{'modified'} = &DateString("March 3rd, 1999 - HH:MM:SS",time());
        $in{'created'} = &DateString("March 3rd, 1999 - HH:MM:SS",time());

        $in{'account_length'} = $in{'account_length'} || $setup{'default_length'};
        $in{'renew_length'} = $in{'renew_length'} || $setup{'default_renew'};
        $in{'sub_groups'} = $in{'sub_groups'} || $setup{'default_groups'};


        $today = int(time / 86400);
        $exp_date = time + 86400 * $in{'account_length'};

        ($sec,$min,$hour,$mday2,$month,$year2) = localtime($exp_date);
        $month++;
        $year2 += 1900;

        if($mday2 < 10) { $mday2 = "0$mday2" };

        $in{'expires_date'} = "$month[$month] $mday2, $year2";
 
        if($setup{'default_no_exp'} || $in{'no_exp'}) { 
           $in{'expires_date'} = "No Expiration";
           $in{'no_expiration'} = "No Expiration";

        }


        $in{'num'} = &DB_Add(\%ApprovalsDB, \%in);
        $in{'admin_url'} = $setup{'admin_url'};

        &Send_Email('new_approval');

        print "Content-Type:text/html\n\n";
        print &Template("interface/approve_thanks.html",\%in);
        exit;

      }

}


# ------------------------------------------------------------------------ 
# Function    : Create Form -> Step 2
# Description : Setup Initial Form Data
#
# Usage	      : &Create_Form;
# Arguments   : none
# ------------------------------------------------------------------------ 

sub Create_Account {
     
  &Template("interface/$subscribe_file");

  $in{'created'} = &DateString("March 3rd, 1999 - HH:MM:SS",time());

  if($in{'error'}) {
     $in{'show_error'} = &TemplateCell("error_html",\%in);
  }
 
  &Custom_Code;



  print "Content-type: text/html\n\n" unless ($ContentType++);
  print &Template("interface/$subscribe_file",\%in);


  exit;


}


# ------------------------------------------------------------------------ 
# Function    : Custom Field Code
# Usage	      : &Custom_Code;
# ------------------------------------------------------------------------ 


sub Custom_Code {


  # Create Custom Field HTML
  ###########################################################


   &Template("interface/fields_html.html"); 

   ### Check if record matches keyword query
   $rowcode  = sub { 


   if($customs{'answers'} =~ /\|/) {
      @answers = split(/\|/,$in{"FIELD$customs{'num'}"});

      undef(%answer);

      foreach$answer(@answers) {
         $answer{"$answer"} = 1;

      }          
   }



   if($customs{'question'} && $customs{'required'}) {

      $customs{'question'} = "<b>$customs{'question'}</b>";

   }
  
   # Text Field
   ################################################################

   if($customs{'viewable'} && $customs{'type'} eq "textfield" && $customs{'question'}) { 
      $customs{'value'} = $in{"FIELD$customs{'num'}"};

      $in{'custom_fields'} .= &TemplateCell("textfield",\%customs);
      undef($customs{'value'});

   }

   # TextArea Field
   ################################################################

   if($customs{'viewable'} && $customs{'type'} eq "textarea" && $customs{'question'}) {

      $customs{'value'} = $in{"FIELD$customs{'num'}"};
      $in{'custom_fields'} .= &TemplateCell("textarea",\%customs);
      undef($customs{'value'});

   }
  

   # Radio Options
   ################################################################

   if($customs{'viewable'} && $customs{'type'} eq "radio" && $customs{'question'}) {

       @options = split(/\|/,$customs{'answers'});
       foreach$option(@options) {

          if($in{"FIELD$customs{'num'}"} =~ /^$option$/i) { $checked = " checked" };
          $customs{'radio_options'} .= "<input type=radio name=\"FIELD$customs{'num'}\" value=\"$option\" $checked> $option<br>\n";
          undef($checked)
       }

       $in{'custom_fields'} .= &TemplateCell("radio",\%customs);
       undef($customs{'radio_options'});
   } 

   # Check Box Options
   ################################################################

   if($customs{'viewable'} && $customs{'type'} eq "checkbox" && $customs{'question'}) {

       @options = split(/\|/,$customs{'answers'});
       foreach$option(@options) {
  
          $hash = "FIELD$customs{'num'}";


          if($$hash{"$option"} || $answer{"$option"}) { $checked = " checked" };
          $customs{'checkbox_options'} .= "<input type=checkbox name=\"FIELD$customs{'num'}\" value=\"$option\" $checked> $option<br>\n";
          undef($checked);
       }

       $in{'custom_fields'} .= &TemplateCell("checkbox",\%customs);
       undef($customs{'checkbox_options'});
   } 

   # Drop Down Options
   ################################################################

   if($customs{'viewable'} && $customs{'type'} eq "dropdown" && $customs{'question'}) {

       @options = split(/\|/,$customs{'answers'});
       foreach$option(@options) {

          if($in{"FIELD$customs{'num'}"} =~ /^$option$/i) { $selected = " selected" };
          $customs{'dropdown_options'} .= "<option value=\"$option\" $selected>$option\n";
          undef($selected);
       }

       $in{'custom_fields'} .= &TemplateCell("dropdown",\%customs);
       undef($customs{'dropdown_options'});
   } 

   };
 
   $sortcode = sub {
     $value_a    = (split(/\¡/,$a))[1];
     $value_b    = (split(/\¡/,$b))[1];
     lc($value_b) <=> lc($value_a);
   }; 

   &DB_List(\%CustomsDB, $rowcode, $sortcode, \%customs);


}




# ------------------------------------------------------------------------ 
# Function    : Cycle Passwords
# Arguments   : none
# ------------------------------------------------------------------------ 

sub Cycle_Passwords {


  ### Check if record matches keyword query
  $rowcode  = sub { 

     $in{'crypted_password'} = crypt($in{'password'},PM);
     $reprint .= "$in{'username'}\:$in{'crypted_password'}\n";


      @groups_array = split(/,/,$in{'sub_groups'});
      foreach (@groups_array) {
         if($line_length{$_} > 7000) {
            $return = "\n$_: ";
            undef($group_count{$_});
            undef($line_length{$_});
         } 
 
         $groups{$_} .= "$return$in{'username'} "; 
         $group_count{$_}++;
         undef($return); 
         $line_length{$_} += length($in{'username'}) + 1; 
      }
  };
 

  &DB_List(\%AccountsDB, $rowcode, $sortcode, \%in);

  open(PASSWORDS,">$cgidir/prog_files/.passwords");
  print PASSWORDS "$reprint\n";
  close(PASSWORDS);


  open(GROUPS,">$cgidir/prog_files/.groups");

      foreach $key (sort keys %groups) {
         $groups{$key} =~ s/,/ /gi;
         print GROUPS "$key: $groups{$key}\n";
      }

  close(GROUPS);






}

# ------------------------------------------------------------------------ 
# Function    : Cycle Data File
# Description : Save Program Setup Options
#
# Usage	      : &Setup_Save;
# Arguments   : none
# ------------------------------------------------------------------------ 

sub Cycle_Data {


  $today = int(time / 86400);

  ##########################

  ### Check if record matches keyword query
  $rowcode  = sub { 

     $hey = $in{'username'};

     $days_left = $in{'account_length'} - $today;

     # Send Exp  Warning:
     ###################################################################

     if($setup{'exp_warning'} && $days_left == "$setup{'exp_warning'}" && !$in{'no_expiration'}) {
        $Global{'days_left'} = $days_left;

        &Send_Email('account_warning');

     }
     

     # Send Expiration Email:
     ###################################################################

     if($days_left  < "0"  && !$in{'no_expiration'} && !$in{'renew_length'}) {
        $dont_record = 1;

        push(@expired,$in{'num'});

        &Send_Email('account_expired');

        $in{'account_length'} = "0";
        $in{'modified'} = &DateString("March 3rd, 1999 - HH:MM:SS",time());

        $in{'expires_date'} = "Account Expired";

        &DB_Add(\%InactivesDB, \%in);

     }
     
     # Send Account Renewed Email:
     ###################################################################

     if($days_left  < "0"  && !$in{'no_expiration'} && $in{'renew_length'}) {

        #### Renew this account;

        $today = int(time / 86400);
        $exp_date = time + 86400 * $in{'renew_length'};

        ($sec,$min,$hour,$mday2,$month,$year2) = localtime($exp_date);
        $month++;
        $year2 += 1900;

        if($mday2 < 10) { $mday2 = "0$mday2" };

        $in{'expires_date'} = "$month[$month] $mday2, $year2";
 
        if($in{'no_expiration'}) { $in{'expires_date'} = "No Expiration" };


        if($in{'account_length'} && int($in{'account_length'})) { 
          $in{'account_length'} = $in{'renew_length'} + $today;
       }
        &Send_Email('account_renewed');

     }
     


     # Reprint
     ###################################################################

     if(!$dont_record) { 

        @groups_array = split(/,/,$in{'sub_groups'});
        foreach (@groups_array) {
           if($line_length{$_} > 7000) {
              $return = "\n$_: ";
              undef($group_count{$_});
              undef($line_length{$_});
           } 
 
           $groups{$_} .= "$return$in{'username'} "; 
           $group_count{$_}++;
           undef($return); 
           $line_length{$_} += length($in{'username'}) + 1; 
        }


        $in{'crypted_password'} = crypt($in{'password'},PM);
        $reprint .= "$in{'username'}\:$in{'crypted_password'}\n";
     }


     # Do Not Remember These:

     undef($days_left);
     undef($dont_record);

  };
 
  &DB_ListSave(\%AccountsDB, $rowcode, $sortcode, \%in);

  if(@expired) {
     &DB_Del(\%AccountsDB,@expired);

 }

  open(PASSWORDS,">$cgidir/prog_files/.passwords");
  print PASSWORDS "$reprint\n";
  close(PASSWORDS);


  ##########################

   &DB_Load(\%SetupDB, \%setup_save, 1);
   $setup_save{'last_update'} = &DateString("March 3rd, 1999",time());
   $setup_save{'update_time'} = &DateString("March 3rd, 1999 - HH:MM:SS",time());
   &DB_Save(\%SetupDB, \%setup_save, 1);



}


# ------------------------------------------------------------------------ 
# Send Email :
#
# usage     &Send_Email('file_name');
# ------------------------------------------------------------------------ 

sub Send_Email {

   my($email_file) = $_[0];
   $Global{'admin_email'} = "$setup{'admin_email'}";
   $Global{'company'} = "$setup{'company'}";
   $Global{'cp_url'} = "$setup{'cp_url'}";

   if($in{'no_expiration'}) {
      $in{'expires_date'} = "No Expiration";
   }


   # Send e-Mail Using SMTP:
   ################################################3

   if($setup{'mailprog'} eq "smtp") {

use Net::SMTP;
 
       my $smtp = Net::SMTP->new("$setup{'mail_server'}");
       $smtp->mail("$Global{'admin_email'}");
       $smtp->to("$in{'email'}");
       $smtp->to("$Global{'admin_email'}");
       $smtp->data();
       $body = &Template("emails/$email_file\.txt",\%in);

       $smtp->datasend("$body\n");
       $smtp->dataend();
       $smtp->quit();

   }

   # Send e-Mail Using Sendmail:
   ################################################3

   else {

      open(MAIL,"|$setup{'mailprog_location'} -t") || die("SendMail: Can't open $sendmail : $!\n");
      $body = &Template("emails/$email_file\.txt",\%in);
      print MAIL "$body\n";
      close(MAIL);
   }
}


# ------------------------------------------------------------------------ 
# Function    : Login
# Description : Ask user to enter corrent username and password before
#		allowing them to access the program
#
# Usage	      : &Login;
# Arguments   : none
# ------------------------------------------------------------------------ 

sub Login {

  ### If no username or password is defined in setup options, skip login
  if (!$setup{'login_id'} && !$setup{'login_pw'}) { return(0); }

  ### Read password submitted by user or stored in browser cookie

  if (defined $in{'id'}) { $id = $in{'id'}; } else { $id = $ck{'id'}; }
  if (defined $in{'pw'}) { $pw = $in{'pw'}; } else { $pw = $ck{'pw'}; }

  ### Check login password
  if	($in{'login'} && !defined $in{'pw'})	{ $valid_login = 0; }
  elsif	($setup{'login_pw'} eq $pw)		{ $valid_login = 1; }
  elsif ($id && lc $setup{'login_id'} ne $id)	{ $out{'error'} = "Invalid Username"; }
  elsif ($pw && lc $setup{'login_pw'} ne $pw)	{ $out{'error'} = "Invalid Password"; }
  elsif (defined $in{'id'} && $in{'id'} eq "")	{ $out{'error'} = "Please enter Username"; }
  elsif (defined $in{'pw'} && $in{'pw'} eq "")	{ $out{'error'} = "Please enter password"; }
  elsif ($ENV{'CONTENT_LENGTH'})		{ $out{'error'} = "Login Session Expired"; }
  elsif ($ENV{'QUERY_STRING'})			{ $out{'error'} = "Login Session Expired"; }

  ### unless valid password is entered, redisplay login screen w/ error messages
  if (!$valid_login) {
    $out{'id'} = $id;
    $out{'pw'} = $pw;
    print "Content-type: text/html\n\n" unless ($ContentType++);
    print &Template("prog_templates/_admin_login.html",\%out);
    exit;
    }

  ### Save login password in browser cookie
  $timeout = int($setup{'login_timeout'}) || 1;
  $expires = time+($timeout*60);
  &SetCookie('id',$id,$expires);
  &SetCookie('pw',$pw,$expires);

}


# ------------------------------------------------------------------------ 
# Function    : Logoff
# Description : Logoff program and erase password cookie from browser.  
#		Redirect to Logoff URL if defined or Login page otherwise.
#
# Usage	      : &Logoff;
# Arguments   : none
# ------------------------------------------------------------------------ 

sub Logoff {

  ### Erase password cookie from browser
  &SetCookie('id',"");
  &SetCookie('pw',"");

  ### Redirect to Logoff URL if it's defined
  if ($setup{'logoff_url'}) { 
    ### For Servers that can't redirect properly
    if ($ENV{'SERVER_SOFTWARE'} =~ /PWS/) {
      print "Content-type: text/html\n\n";
      print <<HTML;
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
<meta http-equiv="REFRESH" content="0; URL=$setup{'logoff_url'}">
</head>
<body>

</body>
</html>
HTML
      exit;
      }
    else {
      print "Location: $setup{'logoff_url'}\n\n";
      exit;
      }
    }

  ### otherwise go back to login screen
  else {
    print "Content-type: text/html\n\n" unless ($ContentType++);
    print &Template("prog_templates/_admin_login.html",\%out);
    exit;
    }
}


# ------------------------------------------------------------------------ 
# Function    : About this Program
# Description : Display About Program Page
#
# Usage	      : &About;
# Arguments   : none
# ------------------------------------------------------------------------ 

sub About {

  print "Content-type: text/html\n\n" unless ($ContentType++);
  print &Template("prog_templates/_about.html");
  exit;


}


# ----------------------------------------------------------------------------
# Display Image : Push an Image to Display 
# ----------------------------------------------------------------------------

sub Display_Image {

   $image = "$Global{'cgidir'}/prog_files/$image";		# Set Image to Display

   unless (-e $image) { 
      print "Content-type: text/plain\n\n"; 
      print "Can't locate image '$image', $!";
      exit;
   }


   print "Content-type: image/gif\n\n";

   open(FILE,"<$image");
   binmode(FILE);			# binary input mode (for windows)
   binmode(STDOUT);			# binary output mode (for windows)
   print <FILE>;
   close(FILE);
}


# ----------------------------------------------------------------------------
# Function    : HTML Error
# Description : Catch any die or warn signals and display them on the screen
#		instead of writing them to a (potentially) unaccessable error
#		log file or displaying an ERROR 500 server message.
#
# Usage	      : &HTML_Error;
# Arguments   : none
# ----------------------------------------------------------------------------

sub HTML_Error {

  my($filelock) = "$Global{'cgidir'}/$SetupDB{'filelock'}";

  print "Content-type: text/html\n\n" unless ($ContentType++);
  foreach (@_) { $error .= "$_ "; }

  chomp $error;
  print $error;
  
  exit;

}

# ----------------------------------------------------------------------------
# ReadForm : Read input from CGI form Perl Routine.  Parse input from a 
#            GET or POST form and return a hash of form names and values.
#
# Usage    : %in = &ReadForm; 
#	   : %in = &ReadForm($maxsize); 	# max input size in bytes
# ----------------------------------------------------------------------------

sub ReadForm {

  my($max) = $_[0];					# Max Input Size
  my($name,$value,$pair,@pairs,$buffer,%hash);		# localize variables
  my($file,$path,$ext);					# localize variables
  my($boundary);

  binmode(STDIN);					# for windows systems

  ### Check input size if max input size is defined
  if ($max && ($ENV{'CONTENT_LENGTH'}||length $ENV{'QUERY_STRING'}) > $max) {
    die("ReadForm : Input exceeds max input limit of $max bytes\n");
    }

  ### For web based file uploads: must be enctype="multipart/form-data"
  ($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=(?:"?)(\S+?)(?:"?)$/;
  if ($ENV{'REQUEST_METHOD'} eq "POST" && $ENV{'CONTENT_TYPE'} =~ m|^multipart/form-data|) {
    while (<STDIN>) {
      if (/^--$boundary--/)	{ $buffer .= "--$boundary";  last; }
      else			{ $buffer .= $_; }
      }

    ### Get form name/value info from form data
    @pairs = split(/--$boundary/,$buffer);
    foreach $pair (@pairs) { 
      unless ($pair =~/^(\r\n|\n)Content-Disposition/) { next; }	# Unless data block, skip
      ($name,$value) = $pair =~ /^(?:\r\n|\n)(.*?)(?:\r\n|\n){2}(.*?)(?:\r\n|\n)$/s;
      ($path) = $name =~ /filename="([^"]+)"/;				# Get upload file path
      ($name) = $name =~ /name="([^"]+)"/;				# Get field Name
      ($file) = $path =~ /([^\/\\]+)$/;					# get upload file name
      ($ext)  = $path =~ /([^\.]+)$/;					# get upload file ext
      $hash{"$name"} = $value;
      $hash{"$name"."_path"} = $path;
      $hash{"$name"."_file"} = $file;
      $hash{"$name"."_ext"}  = $ext;
      }
    }

  else {
    ### Read GET or POST form into $buffer (for regular forms)
    if    ($ENV{'REQUEST_METHOD'} eq 'POST') { read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'}); }
    elsif ($ENV{'REQUEST_METHOD'} eq 'GET')  { $buffer = $ENV{'QUERY_STRING'}; }

    @pairs = split(/&/, $buffer);				# Split into name/value pairs
    foreach $pair (@pairs) {					# foreach pair

      if(!$count)  { $count = a };
      $push = "$name=$count=$value";
      $count++;
      push(@pairs2,$push);

      ($name, $value) = split(/=/, $pair);			# split into $name and $value
      $value =~ tr/+/ /;					# replace "+" with " "
      $value =~ s/%([A-F0-9]{2})/pack("C", hex($1))/egi;	# replace %hex with char
      $value =~ s/\r\n/\n/go;					# replace \r\n with \n
      $value =~ s/\"/&quot;/gi;
      $value =~ s/</&lt;/gi;
      $value =~ s/>/&gt;/gi;

      if($name eq "delete_ids") {
         $deletes{"$value"} = 1;
      }

      if($name eq "delete_approval_ids") {
         $approval_deletes{"$value"} = 1;
      }

      if($name eq "delete_inactive_ids") {
         $inactive_deletes{"$value"} = 1;
      }


      if($name eq "ids") {

         push(@deletes,$value);
         $conf{"$value"} = 1;

      }


     if($name =~ /FIELD/) {
         $$name{"$value"} = 1;
      }


      if($hash{$name}) {
         $two{$name} = 1;
#        print "Content-Type: text/html\n\n";
#         print "$name = $value\n";
#         exit;

      }

      $multiples{$name} .= "$value\|";
    

      $hash{$name} = $value;

     }
  }

  ### Convert image submit button vars (var.x & var.y) to normal vars (var)
  foreach (keys %hash) { if (/^(.*)(\.x|\.y)$/) { $hash{$1} = "true"; }}

  return %hash;


  }


# ------------------------------------------------------------------------ 
# Valid Email : Check for valid email field
#
# usage       : if (&Valid_Email('info@edisdigital.com')) { ... }
#	      : returns 0=invalid 1=valid
# ------------------------------------------------------------------------ 

sub Valid_Email {

  my($email) = $_[0];
  my($user,$host) = split(/@/,$email);              # split into user @ host

  if ($email eq "")                                      { return 0; } # No email address  
  if ($email =~ /[^A-Za-z0-9-_\.\@]/)                    { return 0; } # Invalid characters
  if ($user !~ /^([\w-]+[\w-.])*[\w-]+$/)                { return 0; } # Invalid format
  if ($host !~ /^([\w-]+[\w-.])*[\w-]+\.[A-Za-z]{2,4}$/) { return 0; } # Invalid format

  return 1;

}

# ------------------------------------------------------------------------ 
# Template : Open a template file, translate variables and return contents
#	     If hash is specified var names are read from hash, otherwise
#	     vars are used.
#
# usage    : print &Template("filename.html",\%out);
# ------------------------------------------------------------------------ 

sub Template {  

  if (!$_[0])				{ die "Template : No template file was specified!\n"; }
  if (!-e "$Global{'cgidir'}/$_[0]")	{ die "Template : Template file '$Global{'cgidir'}/$_[0]' does not exist!\n"; }
  if ($_[1] && ref($_[1]) ne "HASH")	{ die "Template : The second argument must be a HASH reference or undefined!\n"; }

  my($file)	= "$Global{'cgidir'}/$_[0]";		# template file
  my($hashref)	= $_[1];				# hash reference
  my(%hash)	= %{$hashref};				# variable translation hash
  my($content);						# file contents
  local(*FILE);						# localize filehandle

  ### Assign global vars
  if ($hashref)	{ foreach (keys %Global) { $hash{$_} = $Global{$_}; }}
  else		{ foreach (keys %Global) { ${$_} = $Global{$_}; }}

  open(FILE, "<$file") || die "Template : Couldn't open $file! $!\n";
  while (<FILE>) { $content .= $_; }
  close(FILE);

  for ($content) {
    s/<!-- template insert\s?:\s?(.*?) -->/\1/gi;		# insert content

    s/<!-- templatecell\s?:\s?([A-Za-z0-9_\.]+) -->(?:\r\n|\n)?(.*?)<!-- \/templatecell\s?:\s? \1 -->/
	$TemplateCell{$1}=$2;''/gesi;				# define template cells

    if ($hashref)	{ s/\$(\w+)\$/$hash{$1}/g; }		# translate $var$ into $hash{'var'}
    else		{ s/\$(\w+)\$/${$1}/g; }		# translate $var$ into ${'var'}
    }

  return $content;						# return content with vars translated

}

# ------------------------------------------------------------------------ 
# TemplateCell : Return a template cell with translated variables.
#                Before you can read a cell you need to load the template.
#		 If hash is specified var names are read from hash,
#		 otherwise vars are used.
#
# usage : print &TemplateCell("cellname",\%in);
# ------------------------------------------------------------------------ 

sub TemplateCell {  

  if (!$_[0])				{ die "Template : No template cell was specified!\n"; }
  if (!defined $TemplateCell{$_[0]})	{ die "Template : Template cell '$_[0]' is not defined!\n"; }
  if ($_[1] && ref($_[1]) ne "HASH")	{ die "Template : The second argument must be a HASH reference or undefined!\n"; }

  my($cellname)	= $_[0];				# template cell name
  my($hashref)	= $_[1];				# hash reference
  my(%hash)	= %{$hashref};				# variable translation hash
  my($content)  = $TemplateCell{$cellname};		# file contents
  local(*FILE);						# localize filehandle

  ### Assign global vars
  if ($hashref)	{ foreach (keys %Global) { $hash{$_} = $Global{$_}; }}
  else		{ foreach (keys %Global) { ${$_} = $Global{$_}; }}

  if ($hashref)	{ $content =~ s/\$(\w+)\$/$hash{$1}/g; }# translate $var$ into $hash{'var'}
  else		{ $content =~ s/\$(\w+)\$/${$1}/g; }	# translate $var$ into ${'var'}

  return $content;					# return content with vars translated

}

# ----------------------------------------------------------------------------
# FileLock : File locking/unlocking Perl routines.
#
# Usage    : &FileLock("$lockdir");
#	   : &FileUnlock("$lockdir");
# ----------------------------------------------------------------------------

sub FileLock   {
  my($i);					# sleep counter
  while (!mkdir($_[0],0777)) {			# if there already is a lock
    sleep 1;					# sleep for 1 sec and try again
    if (++$i>60) { die("File_Lock : Can't create filelock : $!\n"); }		
    }
  }

sub FileUnlock {
  rmdir($_[0]);					# remove file lock dir
  }

# ------------------------------------------------------------------------ 
# Log    : Make a dated entry in a log file
#
# usage  : &Log($file,$data);
# ------------------------------------------------------------------------ 

sub Log {

  local (*FILE);        # Localize filehandle
  my($file,$data) = @_;
  my $datetime       = localtime(time);

  open(FILE,">>$file") || die ("Log : Can't append to $file : $!\n");
  print FILE "[$datetime] $data\n";
  close(FILE);
}


# ------------------------------------------------------------------------ 
# Tail  : Read last few lines from a text file
#
# usage : $lines = $Tail($file,20);
# ------------------------------------------------------------------------ 

sub Tail {

  local (*FILE);             # Localize filehandle
  my($file)  = $_[0];        # File to read 
  my($lines) = $_[1] || 10;  # Lines to read in
  my($buffer,@lines);

  $buffer = $lines*80;       # How much to read in

  open(FILE,"<$file") || die ("Tail : Can't open $file : $!\n");
 
  ### Read lines from file

  while (@lines < $lines) {       # while lines read < lines requested
    if ($buffer >= -s FILE) {     # if buffer >= file size
      seek(FILE,0,0);             # go to start of file
      @lines = <FILE>;            # read all lines into @lines
      last;                       # and exit this while loop
      }  
    else {                        # else if buffer isn't >= file size
      seek(FILE,-$buffer,2);      # read in buffer size from end of file
      ($_,@lines) = <FILE>;       # break that up into full lines
      $buffer += 80;              # up buffer in case we need another loop
      }
    }
  close(FILE);

  ### Return right number of lines
  
  # unless there is less lines than requested shorten array
  unless (@lines < $lines) { @lines = @lines[($#lines-$lines+1)..$#lines]; }

  return @lines;
}


# ----------------------------------------------------------------------------
# MIME64 : MIME64 encoding/decoding Perl routines.  MIME64 is a common base64
#          encoding scheme documented in RFC1341, section 5.2.
#
# Usage  : $mime64_text = &MIME64_Encode("$plaintext");
#	 : $plaintext   = &MIME64_Decode("$mime64_text");
# ----------------------------------------------------------------------------

sub MIME64_Encode {    
  my($in)  = $_[0];					# text to encode
  my(@b64) = ((A..Z,a..z,0..9),'+','/');		# Base 64 char set to use
  my($out) = unpack("B*",$in);				# Convert to binary
  $out=~ s/(\d{6}|\d+$)/$b64[ord(pack"B*","00$1")]/ge;	# convert 3 bytes to 4
  while (length($out)%4) { $out .= "="; }		# Pad string with '='
  return $out;						# Return encoded text
  }

sub MIME64_Decode {
  my($in)  = $_[0];					# encoded text to decode
  my(%b64);						# Base 64 char set hash
  my($out);						# decoded text variable
  for((A..Z,a..z,0..9),'+','/'){ $b64{$_} = $i++ }	# Base 64 char set to use
  $in = $_[0] || return "MIME64 : Nothing to decode";	# Get input or return
  $in =~ s/[^A-Za-z0-9+\/]//g;				# Remove invalid chars
  $in =~ s/[A-Za-z0-9+\/]/unpack"B*",chr($b64{$&})/ge;	# b64 offset val -> bin
  $in =~ s/\d\d(\d{6})/$1/g;				# Convert 8 bits to 6
  $in =~ s/\d{8}/$out.=pack("B*",$&)/ge;		# Convert bin to text
  return $out;						# Return decoded text
  }


# ----------------------------------------------------------------------------
# URL    : URL encoding/decoding Perl routines.  URL encoding is an common 
#          encoding scheme where non A-Za-z0-9+*.@_- characters are replaced
#          with a character triplet of "%" followed by the two hex digits.
#
# Usage  : $URL_encoded = &URL_Encode("$plaintext");
#	 : $plaintext   = &URL_Decode("$URL_encoded");
# ----------------------------------------------------------------------------

sub URL_Encode {
  my($text)  = $_[0];					# text to URL encode
  $text =~ tr/ /+/;					# replace " " with "+"
  $text =~ s/[^A-Za-z0-9\+\*\.\@\_\-]/			# replace odd chars
             uc sprintf("%%%02x",ord($&))/egx;		#   with %hex value
  return $text;						# return URL encoded text
  }

sub URL_Decode {
  my($text)  = $_[0];					# URL encoded text to decode
  $text =~ tr/+/ /;					# replace "+" with " "
  $text =~ s/%([A-F0-9]{2})/pack("C", hex($1))/egi;	# replace %hex with chars
  return $text;						# return decoded plain text
  }


# ----------------------------------------------------------------------------
# Cookie : Perl routines for setting/reading browser cookies.
#        : Cookies have a max size of 4k and each host can send up to 20.
#
# Usage  : &SetCookie("name","value");
#        : %cookie = &ReadCookie;
# ----------------------------------------------------------------------------

sub SetCookie {

  my($cookie_info);
  my($name,$value,$exp,$path,$domain,$secure) = @_;
  my($expires);

  # $name 	- cookie name (ie: username)
  # $value	- cookie value (ie: "joe user")
  # $exp	- exp date, cookie will be deleted at this date. Format: time() which gets translated into: Wdy, DD-Mon-YYYY HH:MM:SS GMT
  # $path	- Cookie is sent only when this path is accessed   (ie: /);
  # $domain	- Cookie is sent only when this domain is accessed (ie: .edis.org)
  # $secure	- Cookie is sent only with secure https connection

  unless (defined $name) { die("SetCookie : Cookie name must be specified\n"); }
  if ($exp && $exp ne int($exp)) { die("SetCookie : Expire Date isn't in seconds using time();\n"); }

  if ($exp) {
    ### Expires Date Format (Wdy, DD-Mon-YYYY HH:MM:SS GMT)
    $expires = &DateString("Mon, 01-Jan-1999 HH:MM:SS GMT",$exp,'GMT');
    }

  if ($name)		{ $name  = &URL_Encode($name); }
  if ($value)		{ $value = &URL_Encode($value); }
  if ($exp)		{ $cookie_info .= "expires=$expires; "; }
  if ($path)		{ $cookie_info .= "path=$path; "; }
  if ($domain)		{ $cookie_info .= "domain=$domain; "; }
  if ($secure)		{ $cookie_info .= "secure; "; }

  print "Set-Cookie: $name=$value; $cookie_info\n";

  }

sub ReadCookie {

  my($cookie,$name,$value,%jar);

  foreach $cookie (split(/; /,$ENV{'HTTP_COOKIE'})) {		# for each cookie sent
    ($name,$value) = split(/=/,$cookie);			# split into name/value
    foreach($name,$value) { $_ = &URL_Decode($_); }		# URL decode strings
    $jar{$name}=$value;						# and put into %jar hash
    }

   return %jar;							# return %jar hash

}

# -----------------------------------------------------------------------------
# Function    :	DateString
# Description :	This function provides an easy method to obtain a formatted
#		date string.  The function reads the sample format provided 
#		and returns the date in that format using the value specified
#		in the time argument (or time() if no argument is specified).
#
# Usage	      : print &DateString("Mon, Mar 3rd, 1999 - HH:MM:SS",time());
# -----------------------------------------------------------------------------

sub DateString { 

  my $str  = $_[0];		# date string
  my $time = $_[1] || time;	# time 
  my $GMT  = $_[2];		# use GMT

  if ($time ne int($time)) { die("DateString : Time value must be an integer\n"); }

  my($sec,$min,$hour,$day,$mon,$year,$wday);

  if ($GMT)	{ ($sec,$min,$hour,$day,$mon,$year,$wday) = gmtime($time); }
  else		{ ($sec,$min,$hour,$day,$mon,$year,$wday) = localtime($time); }

  my(%wday,%weekday,%mon,%month);
  my(@wday)	= qw(Sun Mon Tue Wed Thu Fri Sat);
  my(@weekday)	= qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
  my(@mon)	= qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  my(@month)	= qw(January February March April May June July August September October November December);

  foreach (@wday)	{ $wday{lc $_}++; }
  foreach (@weekday)	{ $weekday{lc $_}++; }
  foreach (@mon)	{ $mon{lc $_}++; }
  foreach (@month)	{ $month{lc $_}++; }

  ### Match wday, weekday, mon, month
  $str =~ s/\b[A-Za-z]{3,9}\b/
    if ($wday{lc $&}) {						# match wday
      if    (uc($&) eq $&) { uc $wday[$wday]; }			# uppercase wday
      elsif (lc($&) eq $&) { lc $wday[$wday]; }			# lowercase wday
      else		   { ucfirst lc $wday[$wday]; }		# ucfirst wday
      }
    elsif ($weekday{lc $&}) {					# match weekday
      if    (uc($&) eq $&) { uc $weekday[$wday]; }		# uppercase weekday
      elsif (lc($&) eq $&) { lc $weekday[$wday]; }		# lowercase weekday
      else		   { ucfirst lc $weekday[$wday]; }	# ucfirst weekday
      }
    elsif ($mon{lc $&}) {					# match mon
      if    (uc($&) eq $&) { uc $mon[$mon]; }			# uppercase mon
      elsif (lc($&) eq $&) { lc $mon[$mon]; }			# lowercase mon
      else		   { ucfirst lc $mon[$mon]; }		# ucfirst mon
      }
    elsif ($month{lc $&}) {					# match month
      if    (uc($&) eq $&) { uc $month[$mon]; }			# uppercase month
      elsif (lc($&) eq $&) { lc $month[$mon]; }			# lowercase month
      else		   { ucfirst lc $month[$mon]; }		# ucfirst month
      }
    else		{ $&; }
    /ge;

  ### Match year, day, 0 padded day
  $str =~ s/\d{1,4}\b/
    if    (length $& == 4)	{ $year + 1900; }		# match year
    elsif (length $& <= 2) {					# match day
      if (substr($&,0,1) eq 0)	{ sprintf("%02d",$day); }	# 0-padded day
      else			{ $day;	}			# day
      }
    else		{ $&; }
    /ge;

  ### Match 1st, 2nd, 3rd, 4th format day
  $str =~ s/(\d{1,2})(st|nd|rd|th)/				# match (Nth) day format
    if    ($day == 1 || $day == 21 || $day == 31)	{ $day."st"; }
    elsif ($day == 2 || $day == 22)			{ $day."nd"; }
    elsif ($day == 3 || $day == 23)			{ $day."rd"; }
    else						{ $day."th"; }
    /gei;

  ### Match second, minute, hour
  $str =~ s/SS/sprintf("%02d",$sec)/gei;		# match seconds
  $str =~ s/MM/sprintf("%02d",$min)/gei;		# match minutes
  $str =~ s/HH/sprintf("%02d",$hour)/gei;		# match hours

  return $str;

  }


# ----------------------------------------------------------------------------

# ---------------------------------------------------------------------------- 
# DB_Count : Count the number of records and return that value.
#
# example : &DB_List(\%DBDef);
# ---------------------------------------------------------------------------- 

sub DB_Count {

  ### Check input
  if (ref($_[0]) ne "HASH")		{ die "DB_List : The first argument must be a HASH reference!\n"; }
  if (!$_[0]->{'datafile'})		{ die "DB_List : No datafile was specified in the DB definition!\n"; }
  if (!$_[0]->{'filelock'})		{ die "DB_List : No filelock was specified in the DB definition!\n"; }
  if (ref($_[0]->{fields}) ne "ARRAY")	{ die "DB_List : Field names in the DB definition must be a ARRAY reference!\n"; }
  if ($#{$_[0]->{fields}} < 0)		{ die "DB_List : No fields were specified in the DB definition!\n"; }

  ### Define vars
  my($datafile)	= "$Global{'cgidir'}/$_[0]->{'datafile'}";# DB datafile
  my($filelock)	= "$Global{'cgidir'}/$_[0]->{'filelock'}";# DB filelock dir
  my(@fields)	= @{$_[0]->{fields}};			# DB field names
  my($backup)	= $_[0]->{'backup'};			# backup setting
  $datafile    .= $_[0]->{'cgiext'};			# cgi ext for datafile
  my($count);						# DB records

  unless (-e $datafile) { return 0; }			# Check if file exists
  if ($backup) { &DB_Backup($_[0]); }			# Backup Datafile

  ### Load Data
  &DB_Lock($filelock);					# Create File Lock
  open(FILE,"<$datafile") || die("DB_List : Can't open '$datafile'. $!\n");
  $count = grep(/^\d/,<FILE>);				# Count Records
  close(FILE);						# Close File
  &DB_Unlock($filelock);				# Remove File Lock

  return $count;					# return records counted

}

# ---------------------------------------------------------------------------- 
# DB_List : List all records in the database, sorting with $sortcode and 
#           executing $rowcode on each record.  Field names/values are loaded
#	    into %out for each record so you can work with them in $rowcode.
#
# example : &DB_List(\%DBDef, $rowcode, $sortcode, \%out);
# ---------------------------------------------------------------------------- 

sub DB_List {

  ### Check input
  if (ref($_[0]) ne "HASH")		{ die "DB_List : The first argument must be a HASH reference!\n"; }
  if (ref($_[1]) ne "CODE" && $_[1])	{ die "DB_List : The second argument must be a CODE reference!\n"; }
  if (ref($_[2]) ne "CODE" && $_[2])	{ die "DB_List : The third argument must be a CODE reference!\n"; }
  if (ref($_[3]) ne "HASH" && $_[3])	{ die "DB_List : The fourth argument must be a HASH reference!\n"; }
  if (!$_[0]->{'datafile'})		{ die "DB_List : No datafile was specified in the DB definition!\n"; }
  if (!$_[0]->{'filelock'})		{ die "DB_List : No filelock was specified in the DB definition!\n"; }
  if (ref($_[0]->{fields}) ne "ARRAY")	{ die "DB_List : Field names in the DB definition must be a ARRAY reference!\n"; }
  if ($#{$_[0]->{fields}} < 0)		{ die "DB_List : No fields were specified in the DB definition!\n"; }

  ### Define vars
  my($datafile)	= "$Global{'cgidir'}/$_[0]->{'datafile'}";# DB datafile
  my($filelock)	= "$Global{'cgidir'}/$_[0]->{'filelock'}";# DB filelock dir
  my(@fields)   = @{$_[0]->{fields}};			# DB field names
  my($backup)	= $_[0]->{'backup'};			# backup setting
  $datafile    .= $_[0]->{'cgiext'};			# cgi ext for datafile
  my($rowcode)	= $_[1];				# row code reference
  my($sortcode)	= $_[2];				# sort code reference
  my($out)	= $_[3];				# output hash reference
  my(@records);						# DB records
  my(@rfields);						# DB record fields

  unless (-e $datafile) { return(0); }			# Check if file exists
  if ($backup) { &DB_Backup($_[0]); }			# Backup Datafile

  ### Load Data
  &DB_Lock($filelock);					# Create File Lock
  open(FILE,"<$datafile") || die("DB_List : Can't open '$datafile'. $!\n");
  @records = <FILE>;					# Load records into array
  close(FILE);						# Close File
  &DB_Unlock($filelock);				# Remove File Lock

  ### Sort Records
  if ($sortcode && &$sortcode ne "") { @records = sort { &$sortcode } @records; }

  ### List Records
  foreach (@records) {
    /^\d/ || next;					# skip non-record lines
    s/[^¡]+$//;						# remove return/nextline
    undef %$out;					# undefine hash
    @rfields = split(/\¡/);				# Split record into fields
    for $i (0..$#fields) {				# decode/define field values
      $out->{$fields[$i]} = $rfields[$i];
      $out->{$fields[$i]} =~ s/¿([A-F0-9]{2})/pack("C",hex($1))/egix;
      }
    &$rowcode;						# Execute row code reference
    }
}

# ---------------------------------------------------------------------------- 
# DB_ListPage : Display page x of the the database broken down into pages of 
#		y listings each.
#
# example : &DB_ListPage(\%DBDef, \&query, \&match, \&sort, \%out, $pagenum, $perpage);
#
# returns : ($pcount, $mcount, $rcount, $cpage, $lpage, $npage)
#	  : (page count, match count, rec count, current page, last page, next page)
# ---------------------------------------------------------------------------- 

sub DB_ListPage {

  ### Check input
  if (ref($_[0]) ne "HASH")		{ die "DB_ListPage : The first argument must be a HASH reference!\n"; }
  if (ref($_[1]) ne "CODE" && $_[1])	{ die "DB_ListPage : The second argument must be a CODE reference!\n"; }
  if (ref($_[2]) ne "CODE" && $_[2])	{ die "DB_ListPage : The third argument must be a CODE reference!\n"; }
  if (ref($_[3]) ne "CODE" && $_[3])	{ die "DB_ListPage : The fourth argument must be a CODE reference!\n"; }
  if (ref($_[4]) ne "HASH" && $_[4])	{ die "DB_ListPage : The fifth argument must be a HASH reference!\n"; }
  if ($_[5] =~ /[^0-9]/)		{ die "DB_ListPage : Page number value contains non-numeric characters!\n"; }
  if (!$_[6])				{ die "DB_ListPage : No Records PerPage value was specified!\n"; }
  if ($_[6] =~ /[^0-9]/)		{ die "DB_ListPage : Records PerPage value contains non-numeric characters!\n"; }
  if (!$_[0]->{'datafile'})		{ die "DB_ListPage : No datafile was specified in the DB definition!\n"; }
  if (!$_[0]->{'filelock'})		{ die "DB_ListPage : No filelock was specified in the DB definition!\n"; }
  if (ref($_[0]->{fields}) ne "ARRAY")	{ die "DB_ListPage : Field names in the DB definition must be a ARRAY reference!\n"; }
  if ($#{$_[0]->{fields}} < 0)		{ die "DB_ListPage : No fields were specified in the DB definition!\n"; }

  ### Define vars
  my($datafile)	= "$Global{'cgidir'}/$_[0]->{'datafile'}";# DB datafile
  my($filelock)	= "$Global{'cgidir'}/$_[0]->{'filelock'}";# DB filelock dir
  my(@fields)   = @{$_[0]->{fields}};			# DB field names
  my($backup)	= $_[0]->{'backup'};			# backup setting
  $datafile    .= $_[0]->{'cgiext'};			# cgi ext for datafile
  my($querycode)= $_[1];				# query code reference
  my($matchcode)= $_[2];				# query match code reference
  my($sortcode)	= $_[3];				# sort code reference
  my($out)	= $_[4];				# output hash reference
  my($perpage)	= int $_[6];				# records per "page"
  my($pcount)   = 0;					# page count
  my($mcount)   = 0;					# match count (records that match $query)
  my($rcount)   = 0;					# record count
  my($cpage)    = int $_[5] || 1;			# current page number
  my($lpage)    = 0;					# last page number (cpage -1 looping)
  my($npage)    = 0;					# next page number (cpage +1 looping)

  my(@records);						# DB records
  my(@rfields);						# DB record fields

  unless (-e $datafile) { return(0,0,0,0,0,0); }	# Check if file exists
  if ($backup) { &DB_Backup($_[0]); }			# Backup Datafile

  ### Load Data
  &DB_Lock($filelock);					# Create File Lock
  open(FILE,"<$datafile") || die("DB_List : Can't open '$datafile'. $!\n");
  @records = <FILE>;					# Load records into array
  close(FILE);						# Close File
  &DB_Unlock($filelock);				# Remove File Lock

  ### Sort Records
  if ($sortcode && &$sortcode ne "") { @records = sort { &$sortcode } @records; }

  ### List Records
  foreach (@records) {
    /^\d/ || next;					# skip non-record lines
    $rcount++;						# record counter
    s/[^\¡]+$//;						# remove return/nextline
    undef %$out;					# undefine hash
    @rfields = split(/\¡/);				# Split record into fields
    for $i (0..$#fields) {				# decode/define field values
      $out->{$fields[$i]} = $rfields[$i];
      $out->{$fields[$i]} =~ s/¿([A-F0-9]{2})/pack("C",hex($1))/egix;
      }

    ### Perform Query
    if (&$querycode) { 					# if query returns true
      $mcount++;					# match counter
      my($thispage) = ($mcount%$perpage) ? int($mcount/$perpage)+1 : $mcount/$perpage;
      if ($thispage == $cpage) {			# Only exec for selected page
        &$matchcode;					# Execute query match code
        }
      }
    }

  ### Calculate Page Count
  $pcount = int ($mcount / $perpage);			# Match Count / Results per page
  if ($mcount % $perpage) { $pcount++;}			# round up if we don't have an integer

  ### Calculate Page Numbers (last, next)
  if (($cpage-1) < 1 || ($cpage-1) > $pcount)	{ $lpage = $pcount; }
  else						{ $lpage = $cpage-1; }
  if (($cpage+1) >$pcount)			{ $npage = 1; }
  else						{ $npage = $cpage+1; }
  if (!$pcount) { $cpage = $lpage = $npage = 0; }


  return ($pcount, $mcount, $rcount, $cpage, $lpage, $npage);

}

# ---------------------------------------------------------------------------- 
# DB_ListSave : List all records in the database, sorting with $sortcode and 
#		executing $rowcode on each record.  Field names/values are
#		loaded into %out for each record so you can work with them
#		in $rowcode.  Field values are updated after each call to
#		$rowcode, allowing you to update the entire DB in one pass.
#
# example : &DB_ListSave(\%DBDef, $rowcode, $sortcode, \%out);
# ---------------------------------------------------------------------------- 

sub DB_ListSave {

  ### Check input
  if (ref($_[0]) ne "HASH")		{ die "DB_ListSave : The first argument must be a HASH reference!\n"; }
  if (ref($_[1]) ne "CODE" && $_[1])	{ die "DB_ListSave : The second argument must be a CODE reference!\n"; }
  if (ref($_[2]) ne "CODE" && $_[2])	{ die "DB_ListSave : The third argument must be a CODE reference!\n"; }
  if (ref($_[3]) ne "HASH" && $_[3])	{ die "DB_ListSave : The fourth argument must be a HASH reference!\n"; }
  if (!$_[0]->{'datafile'})		{ die "DB_ListSave : No datafile was specified in the DB definition!\n"; }
  if (!$_[0]->{'filelock'})		{ die "DB_ListSave : No filelock was specified in the DB definition!\n"; }
  if (ref($_[0]->{fields}) ne "ARRAY")	{ die "DB_ListSave : Field names in the DB definition must be a ARRAY reference!\n"; }
  if ($#{$_[0]->{fields}} < 0)		{ die "DB_ListSave : No fields were specified in the DB definition!\n"; }

  ### Define vars
  my($datafile)	= "$Global{'cgidir'}/$_[0]->{'datafile'}";# DB datafile
  my($filelock)	= "$Global{'cgidir'}/$_[0]->{'filelock'}";# DB filelock dir
  my(@fields)	= @{$_[0]->{fields}};			# DB field names
  my($backup)	= $_[0]->{'backup'};			# backup setting
  $datafile    .= $_[0]->{'cgiext'};			# cgi ext for datafile
  my($rowcode)	= $_[1];				# row code reference
  my($sortcode)	= $_[2];				# sort code reference
  my($out)	= $_[3];				# output hash reference
  my(@records);						# DB records
  my(@rfields);						# DB record fields

  unless (-e $datafile) { return(0); }			# Check if file exists
  if ($backup) { &DB_Backup($_[0]); }			# Backup Datafile

  ### Load Data
  &DB_Lock($filelock);					# Create File Lock
  open(FILE,"<$datafile") || die("DB_List : Can't open '$datafile'. $!\n");
  @records = <FILE>;					# Load records into array
  close(FILE);						# Close File

  ### Sort Records
  if ($sortcode && &$sortcode ne "") { @records = sort { &$sortcode } @records; }

  ### List Records
  foreach (@records) {
    /^\d/ || next;					# skip non-record lines
    s/[^¡]+$//;						# remove return/nextline
    undef %$out;					# undefine hash
    @rfields = split(/\¡/);				# Split record into fields
    for $i (0..$#fields) {				# decode/define field values
      $out->{$fields[$i]} = $rfields[$i];
      $out->{$fields[$i]} =~ s/¿([A-F0-9]{2})/pack("C",hex($1))/egix;
      }
    &$rowcode;						# Execute row code reference

    ### Update Record
    $_ = "$rfields[$i]¡";				# Record Number
    for $i (1..$#fields) {				# for each field
      my($enc) = $out->{$fields[$i]};			# encode/update field values
      $enc =~ s/[\x1a\r\n\¡\¿]/sprintf("¿%02x",ord($&))/egx;
      $_ .= "$enc¡";					# field value
      }
    $_ .= "\n";						# add nextline on end
    }

  ### Save Data
  open(FILE,">$datafile") || die("DB_List : Can't write $datafile. $!\n");
  print FILE qq|#!$^X\n|;				# print no exec header
  print FILE qq|print "Content-type: text/plain\\n\\n|;	
  print FILE qq|This is a data file.";\n__END__\n|;
  foreach (@records) {
    /^\d/ || next;					# skip non-record lines
    s/[^¡]+$//;						# remove return/nextline
    print FILE "$_\n";					# Save DB Records
    }
  close(FILE);
  &DB_Unlock($filelock);				# Remove File Lock

}

# ---------------------------------------------------------------------------- 
# DB_Add  : Add a new record to the database, find an unused record number.
#	    Read field values from %in hash.
#
# example : &DB_Add(\%DBDef, \%in, $num);
# ---------------------------------------------------------------------------- 

sub DB_Add {

  ### Check input
  if (ref($_[0]) ne "HASH")		{ die "DB_Add : The first argument must be a HASH reference!\n"; }
  if (ref($_[1]) ne "HASH")		{ die "DB_Add : The second argument must be a HASH reference!\n"; }
  if (!$_[0]->{'datafile'})		{ die "DB_Add : No datafile was specified in the DB definition!\n"; }
  if (!$_[0]->{'filelock'})		{ die "DB_Add : No filelock was specified in the DB definition!\n"; }
  if (ref($_[0]->{fields}) ne "ARRAY")	{ die "DB_Add : Field names in the DB definition must be a ARRAY reference!\n"; }
  if ($#{$_[0]->{fields}} < 0)		{ die "DB_Add : No fields were specified in the DB definition!\n"; }
  if ($_[2] && $_[2] != int $_[2])	{ die "DB_Add : Record number to create must be an integer!\n"; }

  ### Define vars
  my($datafile)	= "$Global{'cgidir'}/$_[0]->{'datafile'}";# DB datafile
  my($filelock)	= "$Global{'cgidir'}/$_[0]->{'filelock'}";# DB filelock dir
  my(@fields)	= @{$_[0]->{fields}};			# DB field names
  my($backup)	= $_[0]->{'backup'};			# backup setting
  $datafile    .= $_[0]->{'cgiext'};			# cgi ext for datafile
  my($in)	= $_[1];				# input hash reference
  my($newnum)	= int $_[2];				# record number to create

  my(@records);						# DB records
  my(@rfields);						# DB record fields
  my(%rnum);						# Hash of record numbers

  if ((-e $datafile) && $backup) { &DB_Backup($_[0]); }	# Backup Datafile

  ### Load Data
  &DB_Lock($filelock);					# Create File Lock
  if (-e $datafile) {
    open(FILE,"<$datafile") || die("DB_Add : Error, Can't open '$datafile'. $!\n");
    @records = <FILE>;					# Load DB Records
    close(FILE);
    }

  ### Find unused record number
  foreach (@records) {					# create a hash of record numbers
    /^\d/ || next;					# skip non-record lines
    $rnum{(split(/\¡/))[0]} = 1;			# store record num in hash
    }

  if ($newnum && $rnum{$newnum}) {			# if user has specified existing record number
     &DB_Unlock($filelock);				# Remove File Lock
     return &DB_Save(@_);				# Update existing record
     }
  elsif ($newnum) { $nnum = $newnum; }			# use newnum as new record number
  else {
    $nnum = 1;						# start at 1 and keep counting
    while ($rnum{$nnum}) { $nnum++; }			# untill we find an unused number
    }

  ### Save Data
  open(FILE,">$datafile") || die("DB_Add : Can't write to $datafile. $!\n"); 
  print FILE qq|#!$^X\n|;				# print no exec header
  print FILE qq|print "Content-type: text/plain\\n\\n|;	
  print FILE qq|This is a data file.";\n__END__\n|;
  foreach (@records) {
    /^\d/ || next;					# skip non-record lines
    s/[^¡]+$//;						# remove return/nextline
    print FILE "$_\n";					# Save DB Records
    }
  my($line) = "$nnum¡";					# New Record Number
  for $i (1..$#fields) {				# for each field name
      my($enc) = $in->{$fields[$i]};			# encode/update field values
      $enc =~ s/[\x1a\r\n\¡\¿]/sprintf("¿%02x",ord($&))/egx;
      $line .= "$enc¡";					# output encoded field value
    }
  print FILE "$line\n";					# Add nextline to end
  close(FILE);						# Close File
  &DB_Unlock($filelock);				# Remove File Lock

  return $nnum;						# Return new record number

}


# ---------------------------------------------------------------------------- 
# DB_Load  : Load a record from the database, Read field names/values into the
#	    hash %out.  $rnum is the record number to load
#
# example : &DB_Load(\%DBDef, \%out, $rnum);
# ---------------------------------------------------------------------------- 

sub DB_Load {

  ### Check input
  if (ref($_[0]) ne "HASH")		{ die "DB_Load : The first argument must be a HASH reference!\n"; }
  if (ref($_[1]) ne "HASH")		{ die "DB_Load : The second argument must be a HASH reference!\n"; }
  if (!$_[2])				{ die "DB_Load : No record number was specified!\n"; }
  if ($_[2] =~ /[^0-9]/)		{ die "DB_Load : Record number contains non-numeric characters!\n"; }
  if (!$_[0]->{'datafile'})		{ die "DB_Load : No datafile was specified in the DB definition!\n"; }
  if (!$_[0]->{'filelock'})		{ die "DB_Load : No filelock was specified in the DB definition!\n"; }
  if (ref($_[0]->{fields}) ne "ARRAY")	{ die "DB_Load : Field names in the DB definition must be a ARRAY reference!\n"; }
  if ($#{$_[0]->{fields}} < 0)		{ die "DB_Load : No fields were specified in the DB definition!\n"; }

  ### Define vars
  my($datafile)	= "$Global{'cgidir'}/$_[0]->{'datafile'}";# DB datafile
  my($filelock)	= "$Global{'cgidir'}/$_[0]->{'filelock'}";# DB filelock dir
  my(@fields)	= @{$_[0]->{fields}};			# DB field names
  my($backup)	= $_[0]->{'backup'};			# backup setting
  $datafile    .= $_[0]->{'cgiext'};			# cgi ext for datafile
  my($out)	= $_[1];				# output hash reference
  my($rnum)	= int $_[2];				# record number to load

  my(@records);						# DB records
  my(@rfields);						# DB record fields

  unless (-e $datafile) { return(0); }			# Check if file exists
  if ($backup) { &DB_Backup($_[0]); }			# Backup Datafile

  ### Load Data
  if (-e "$datafile") {
    &DB_Lock($filelock);				# Create File Lock
    open(FILE,"<$datafile") || die("DB_Load : Error, Can't open '$datafile'. $!\n");
    @records = <FILE>;					# Load DB Records
    close(FILE);
    &DB_Unlock($filelock);				# Remove File Lock
    }

  ### Find record number
  foreach (@records) {
    /^$rnum\¡/ || next;					# find record number
    s/[^¡]+$//;						# remove return/nextline
    undef %$out;					# undefine hash
    @rfields = split(/\¡/);				# Split record into fields
    for $i (0..$#fields) {				# decode/define field values
      $out->{$fields[$i]} = $rfields[$i];
      $out->{$fields[$i]} =~ s/¿([A-F0-9]{2})/pack("C",hex($1))/egix;
      }
    return 1;						# found record, return true;
    }
  return 0;						# no record found, return false;
}


# ---------------------------------------------------------------------------- 
# DB_Del  : Erase a record from the database. Return true/false
#	    rnum can be an array of records to erase.
#
# example : &DB_Add(\%DBDef, $rnum);
# ---------------------------------------------------------------------------- 

sub DB_Del {

  ### Check input
  if (ref($_[0]) ne "HASH")		{ die "DB_Del : The first argument must be a HASH reference!\n"; }
  if (!$_[1])				{ die "DB_Del : The second argument must be a record number!\n"; }
  if ($_[1] =~ /[^0-9]/)		{ die "DB_Del : Record number contains non-numeric characters!\n"; }
  if (!$_[0]->{'datafile'})		{ die "DB_Del : No datafile was specified in the DB definition!\n"; }
  if (!$_[0]->{'filelock'})		{ die "DB_Del : No filelock was specified in the DB definition!\n"; }
  if (ref($_[0]->{fields}) ne "ARRAY")	{ die "DB_Del : Field names in the DB definition must be a ARRAY reference!\n"; }
  if ($#{$_[0]->{fields}} < 0)		{ die "DB_Del : No fields were specified in the DB definition!\n"; }

  ### Define vars
  my($datafile)	= "$Global{'cgidir'}/$_[0]->{'datafile'}";# DB datafile
  my($filelock)	= "$Global{'cgidir'}/$_[0]->{'filelock'}";# DB filelock dir
  my(@fields)	= @{$_[0]->{fields}};			# DB field names
  my($backup)	= $_[0]->{'backup'};			# backup setting
  $datafile    .= $_[0]->{'cgiext'};			# cgi ext for datafile
  my($rnum)	= int $_[1];				# record number to load
  my(%rnum);						# hash of records to erase
  my($erased)	= 0;					# record erased flag

  for (1..$#_) { $rnum{$_[$_]}++; }			# create hash of records to erase
  my(@records);						# DB records

  unless (-e $datafile) { return(0); }			# Check if file exists
  if ($backup) { &DB_Backup($_[0]); }			# Backup Datafile

  ### Load Data
  &DB_Lock($filelock);					# Create File Lock
  if (-e "$datafile") {
    open(FILE,"<$datafile") || die("DB_Del : Error, Can't open '$datafile'. $!\n");
    @records = <FILE>;					# Load DB Records
    close(FILE);
    }

  ### Save Data
  open(FILE,">$datafile") || die("DB_Del : Can't write to $datafile. $!\n"); 
  print FILE qq|#!$^X\n|;				# print no exec header
  print FILE qq|print "Content-type: text/plain\\n\\n|;	
  print FILE qq|This is a data file.";\n__END__\n|;
  foreach (@records) {
    /^(\d+)\¡/ || next;					# skip non-record lines
    if ($rnum{$1}) { $erased++; next; }			# skip record to erase
    s/[^¡]+$//;						# remove return/nextline
    print FILE "$_\n";					# Save DB Records
    }
  close(FILE);						# Close File
  &DB_Unlock($filelock);				# Remove File Lock

  return $erased;					# Return number of records erased

}


# ---------------------------------------------------------------------------- 
# DB_Save  : Save/update a record to the database,
#	    Read field values from %in hash.
#
# example : &DB_Save(\%DBDef, \%in, $rnum);
# ---------------------------------------------------------------------------- 

sub DB_Save {

  ### Check input
  if (ref($_[0]) ne "HASH")		{ die "DB_Save : The first argument must be a HASH reference!\n"; }
  if (ref($_[1]) ne "HASH")		{ die "DB_Save : The second argument must be a HASH reference!\n"; }
  if (!$_[2])				{ die "DB_Save : No record number was specified!\n"; }
  if ($_[2] =~ /[^0-9]/)		{ die "DB_Save : Record number contains non-numeric characters!\n"; }
  if (!$_[0]->{'datafile'})		{ die "DB_Save : No datafile was specified in the DB definition!\n"; }
  if (!$_[0]->{'filelock'})		{ die "DB_Save : No filelock was specified in the DB definition!\n"; }
  if (ref($_[0]->{fields}) ne "ARRAY")	{ die "DB_Save : Field names in the DB definition must be a ARRAY reference!\n"; }
  if ($#{$_[0]->{fields}} < 0)		{ die "DB_Save : No fields were specified in the DB definition!\n"; }

  ### Define vars
  my($datafile)	= "$Global{'cgidir'}/$_[0]->{'datafile'}";# DB datafile
  my($filelock)	= "$Global{'cgidir'}/$_[0]->{'filelock'}";# DB filelock dir
  my(@fields)	= @{$_[0]->{fields}};			# DB field names
  my($backup)	= $_[0]->{'backup'};			# backup setting
  $datafile    .= $_[0]->{'cgiext'};			# cgi ext for datafile
  my($in)	= $_[1];				# input hash reference
  my($rnum)	= int $_[2];				# record number
  my($saved)	= 0;					# saved flag

  my(@records);						# DB records
  my(@rfields);						# DB record fields

  if (!-e $datafile) { return &DB_Add(@_); }		# Check DB exists

  if ($backup) { &DB_Backup($_[0]); }			# Backup Datafile

  ### Load Data
  &DB_Lock($filelock);					# Create File Lock
  open(FILE,"<$datafile") || die("DB_Save : Error, Can't open '$datafile'. $!\n");
  @records = <FILE>;					# Load DB Records
  close(FILE);

  ### Save Data
  open(FILE,">$datafile") || die("DB_Add : Can't write to $datafile. $!\n"); 
  print FILE qq|#!$^X\n|;				# print no exec header
  print FILE qq|print "Content-type: text/plain\\n\\n|;	
  print FILE qq|This is a data file.";\n__END__\n|;
  foreach (@records) {
    /^\d/ || next;					# skip non-record lines
    if (/^$rnum\¡/) {					# write "save record"
      my($line) = "$rnum¡";				# Record Number
      for $i (1..$#fields) {				# for each field name
        my($enc) = $in->{$fields[$i]};			# encode/update field values
        $enc =~ s/[\x1a\r\n\¡\¿]/sprintf("¿%02x",ord($&))/egx;
        $line .= "$enc¡";				# output encoded field value
        }
      print FILE "$line\n";				# Add nextline to end
      $saved++;						# toggle saved flag
      next;						# next record
      }
    s/[^¡]+$//;						# remove return/nextline
    print FILE "$_\n";					# Save DB Records
    }
  close(FILE);						# Close File
  &DB_Unlock($filelock);				# Remove File Lock

  unless($saved) { return &DB_Add(@_); }		# If record couldn't be found - add it

}

# ---------------------------------------------------------------------------- 
# DB_Backup : Backup the datafile every (month/day/hour)
#
# example : &DB_Backup(\%DBDef);
# ---------------------------------------------------------------------------- 

sub DB_Backup {

  ### Define vars
  my($datafile)	= "$Global{'cgidir'}/$_[0]->{'datafile'}";# DB datafile
  my($filelock)	= "$Global{'cgidir'}/$_[0]->{'filelock'}";# DB filelock dir
  my($backup)	= $_[0]->{'backup'};			# backup setting
  my($cgiext)   = $_[0]->{'cgiext'};			# cgi ext for datafile
  my($bkupfile);					# backup file

  unless($backup)		{ return; }		# backup disabled
  if ($backup eq "disabled")	{ return; }
  if ($backup eq "none")	{ return; }

  ### Get Current Time
  my($hour,$day,$month,$year)=(localtime(time))[2..5];
  $hour   = sprintf("%02d",$hour);
  $day    = sprintf("%02d",$day);
  $month  = sprintf("%02d",$month+1);
  $year   = sprintf("%04d",$year+1900);

  if	($backup eq "hourly")	{ $bkupfile = "$datafile.$year-$month-$day-$hour-backup$cgiext"; }
  elsif	($backup eq "daily")	{ $bkupfile = "$datafile.$year-$month-$day-backup$cgiext"; }
  elsif	($backup eq "monthly")	{ $bkupfile = "$datafile.$year-$month-backup$cgiext"; }
  elsif	($backup eq "yearly")	{ $bkupfile = "$datafile.$year-backup$cgiext"; }
  else				{ die("DB_Backup : Unknown backup setting\n"); } 

  if (-e $bkupfile) { return; }				# Check if already backed up
  $datafile = "$datafile$cgiext";			# Full datafile name

  ### Backup Data
  &DB_Lock($filelock);					# Create File Lock
  open(FILE,"<$datafile") || die("DB_Backup : Can't open '$datafile'. $!\n");
  open(BKUP,">$bkupfile") || die("DB_Backup : Can't open '$bkupfile'. $!\n");
  print BKUP <FILE>;					# Copy file
  close(FILE);						# Close File
  close(BKUP);						# Close File
  &DB_Unlock($filelock);				# Remove File Lock

}

# ----------------------------------------------------------------------------
# DB_Lock  : Database locking/unlocking Perl routines.
#	     A directory is created to flag the database as locked
#
# Usage    : &DB_Lock("$lockdir");
#	   : &DB_Unlock("$lockdir");
# ----------------------------------------------------------------------------

sub DB_Lock {
  my($filelock) = $_[0];			# Filelock Dir
  my($i);					# sleep counter

  while (!mkdir($filelock,0777)) {		# attempt to make file lock (or)
    sleep 1;					# sleep for 1 sec and try again
    if (++$i>50) { die("DB_Lock : Can't create filelock : $!\n"); }		
    }
  }

sub DB_Unlock {
  my($filelock) = $_[0];			# Filelock Dir
  rmdir($filelock);				# remove file lock dir
  }

# ----------------------------------------------------------------------------
#    Programming by CGI-World.Com of i2-Services, Inc. <Contact@CGI-World.Com)