############################################################
# RMCGI.LIB
#-----------------------------------------------------------
# Basic CGI Routines
# Subroutine List: error
# check_for_lock
# lock_file
# unlock_file
# cgi_init
# cgi_receive
# cgi_decode
# cgi_header
#
############################################################
$done_cgi_head = 0;
$Cookie_Exp_Date = '';
$Cookie_Path = '';
$Cookie_Domain = '';
@Cookie_Encode_Chars = ('\%', '\+', '\;', '\,', '\=', '\&', '\:\:', '\s');
%Cookie_Encode_Chars = ('\%', '%25', '\+', '%2B', '\;', '%3B',
'\,', '%2C', '\=', '%3D', '\&', '%26',
'\:\:', '%3A%3A', '\s', '+');
@Cookie_Decode_Chars = ('\+', '\%3A\%3A', '\%26', '\%3D', '\%2C', '\%3B', '\%2B', '\%25');
%Cookie_Decode_Chars = ('\+', ' ', '\%3A\%3A', '::',
'\%26', '&', '\%3D', '=',
'\%2C', ',', '\%3B', ';',
'\%2B', '+', '\%25', '%');
1;
############################################################
# Error Handler
#-----------------------------------------------------------
sub error {
$error_message = $_[0];
&cgi_header;
print "Error\n";
print "Error
\n";
print "An error has occurred:
\n";
print "$error_message
\n";
print "";
exit;
}
############################################################
# Print an HTTP Header with/without cookies
#-----------------------------------------------------------
sub cgi_header {
local( $obj_cookie, $cookie_name, $cookie_str );
local( $my_cookie_val, $my_cookie_exp, $my_cookie_path );
my $new_cookies = 0;
print "Content-type: text/html\n";
foreach $cookie_name ( keys ( %my_cookies ) ) {
$new_cookies = 1;
$cookie_str = $my_cookies{$cookie_name};
if ( $cookie_str =~ /([^\|]+)\|([^\|]*)\|(.*)/ ) {
$my_cookie_val = $1;
$my_cookie_exp = $2;
$my_cookie_path = $3;
}
elsif ( $cookie_str =~ /([^\|]+)\|(.*)/ ) {
$my_cookie_val = $1;
$my_cookie_exp = $2;
$my_cookie_path = "";
}
else {
$my_cookie_val = $cookie_str;
$my_cookie_exp = "";
$my_cookie_path = "";
}
if ( $my_cookie_exp gt "" ) {
$Cookie_Exp_Date = &Delta_GMT_Date( $my_cookie_exp );
}
if ( $my_cookie_path gt "" ) {
$Cookie_Path = $my_cookie_path;
}
&SetCookie( "$cookie_name", $my_cookie_val );
}
print "\n";
$done_cgi_head = 1;
}
############################################################
# Check for a file lock
#-----------------------------------------------------------
sub check_for_lock {
print "Checking for lock
" if ($debug eq "1");
$file = $_[0];
$original_timestamp = time;
until (!(-e "$data_dir/$file.lock")) {
$timestamp = time;
$wait_time = $timestamp + 1;
while ($wait_time ne $timestamp) {
if ($timestamp eq ($original_timestamp + 5)) {
&error("sub check_for_lock had a lock overrun error and died. Inform the admin.");
}
$timestamp = time;
}
}
}
############################################################
# Lock a File
#-----------------------------------------------------------
sub lock_file {
print "Locking
" if ($debug eq "1");
$file = $_[0];
open(LOCK,">$data_dir/$file.lock") || &error("sub lock_file can't open $file.lock: $!");
close(LOCK);
}
############################################################
# Unlock a file
#-----------------------------------------------------------
sub unlock_file {
print "Unlocking
" if ($debug eq "1");
$file = $_[0];
unlink "$data_dir/$file.lock";
}
############################################################
# Run CGI Initialization Routines
#-----------------------------------------------------------
sub cgi_init {
&cgi_receive;
&cgi_decode;
# This section was a patch added for mission.net users. Its purpose
# is to check to see that there is at least 20meg of diskspace left
# on your server before you update any databases. With each update
# that is done, the entire database is essentially rewritten to the
# drive. If your server runs out of space and someone attempts to
# do an update (without this check), your entire database would be
# lost. It does require the Filesys::Diskspace package to be installed
# on your server to function (which is installed on mission.net).
# NOTE: This is not required however - and most ISPs have other
# measures in place to prevent their servers from filling up.
# $command = "use Filesys::DiskSpace; ( undef, undef, undef, \$kb_avail, undef, undef ) = df \"$data_dir\"";
# eval( $command );
# if ( $@ eq "" ) {
# # 20 MB left is our "warning signal"
# if ( $kb_avail < ( 20 * 1024 ) ) {
# &error( "Unexpected Problem: Low disk space. Contact web site maintainer.");
# exit;
# }
# }
# End Diskspace Check
}
############################################################
# Receive input from user
#-----------------------------------------------------------
sub cgi_receive {
if ($ENV{'REQUEST_METHOD'} eq "POST") {
read(STDIN, $incoming, $ENV{'CONTENT_LENGTH'});
}
else {
$incoming = $ENV{'QUERY_STRING'};
}
}
############################################################
# Decode CGI coding
#-----------------------------------------------------------
sub cgi_decode {
@pairs = split(/&/, $incoming);
foreach (@pairs) {
($name, $value) = split(/=/, $_);
$name =~ tr/+/ /;
$value =~ tr/+/ /;
$name =~ s/%([A-F0-9][A-F0-9])/pack("C", hex($1))/gie;
$value =~ s/%([A-F0-9][A-F0-9])/pack("C", hex($1))/gie;
#### Strip out semicolons unless for special character
$value =~ s/;/$$/g;
$value =~ s/&(\S{1,6})$$/&\1;/g;
$value =~ s/$$/ /g;
$value =~ s/\|/ /g;
$value =~ s/^!/ /g; ## Allow exclamation points in sentences
$value =~ s/"/'/g; ## Replace double quotes with single quotes
#### Strip out carriage returns. Replace them with "
" tags
#### in multi-line inputs (textarea tags). NOTE: All textarea
#### tag names must begin with "txt_"
if ( substr( $name, 0, 4 ) eq "txt_" ) {
$value =~ s/\n/
/gs;
$value =~ s/\cM//gs;
}
else {
$value =~ s/\n/ /gs;
}
#### Skip blank text entry fields
next if ($value eq "");
#### Allow for multiple values of a single name
$FORM{$name} .= ", " if ($FORM{$name});
$FORM{$name} .= $value;
}
}
##############################################################################
# Subroutine: &GetCookies() #
# Description: This subroutine can be called with or without arguments. If #
# arguments are specified, only cookies with names matching #
# those specified will be set in %Cookies. Otherwise, all #
# cookies sent to this script will be set in %Cookies. #
# Usage: &GetCookies([cookie_names]) #
# Variables: cookie_names - These are optional (depicted with []) and #
# specify the names of cookies you wish to set.#
# Can also be called with an array of names. #
# Ex. 'name1','name2' #
# Returns: 1 - If successful and at least one cookie is retrieved. #
# 0 - If no cookies are retrieved. #
##############################################################################
sub GetCookies {
# Localize the variables and read in the cookies they wish to have #
# returned. #
local(@ReturnCookies) = @_;
local($cookie_flag) = 0;
local($cookie,$value);
# If the HTTP_COOKIE environment variable has been set by the call to #
# this script, meaning the browser sent some cookies to us, continue. #
if ($ENV{'HTTP_COOKIE'}) {
# If specific cookies have have been requested, meaning the #
# @ReturnCookies array is not empty, proceed. #
if ($ReturnCookies[0] ne '') {
# For each cookie sent to us: #
foreach (split(/; /,$ENV{'HTTP_COOKIE'})) {
# Split the cookie name and value pairs, separated by '='. #
($cookie,$value) = split(/=/);
# Decode any URL encoding which was done when the compressed #
# cookie was set. #
foreach $char (@Cookie_Decode_Chars) {
$cookie =~ s/$char/$Cookie_Decode_Chars{$char}/g;
$value =~ s/$char/$Cookie_Decode_Chars{$char}/g;
}
# For each cookie to be returned in the @ReturnCookies array:#
foreach $ReturnCookie (@ReturnCookies) {
# If the $ReturnCookie is equal to the current cookie we #
# are analyzing, set the cookie name in the %Cookies #
# associative array equal to the cookie value and set #
# the cookie flag to a true value. #
if ($ReturnCookie eq $cookie) {
$Cookies{$cookie} = $value;
$cookie_flag = "1";
}
}
}
}
# Otherwise, if no specific cookies have been requested, obtain all #
# cookied and place them in the %Cookies associative array. #
else {
# For each cookie that was sent to us by the browser, split the #
# cookie name and value pairs and set the cookie name key in the #
# associative array %Cookies equal to the value of that cookie. #
# Also set the coxokie flag to 1, since we set some cookies. #
foreach (split(/; /,$ENV{'HTTP_COOKIE'})) {
($cookie,$value) = split(/=/);
# Decode any URL encoding which was done when the compressed #
# cookie was set. #
foreach $char (@Cookie_Decode_Chars) {
$cookie =~ s/$char/$Cookie_Decode_Chars{$char}/g;
$value =~ s/$char/$Cookie_Decode_Chars{$char}/g;
}
$Cookies{$cookie} = $value;
}
$cookie_flag = 1;
}
}
# Return the value of the $cookie_flag, true or false, to indicate #
# whether we succeded in reading in a cookie value or not. #
return $cookie_flag;
}
##############################################################################
# Subroutine: &SetCookieExpDate() #
# Description: Sets the expiration date for the cookie. #
# Usage: &SetCookieExpDate('date') #
# Variables: date - The date you wish for the cookie to expire, in the #
# format: Wdy, DD-Mon-YYYY HH:MM:SS GMT #
# Ex. 'Wed, 09-Nov-1999 00:00:00 GMT' #
# Returns: 1 - If successful and date passes regular expression check #
# for format errors and the new ExpDate is set. #
# 0 - If new ExpDate was not set. Check format of date. #
##############################################################################
sub SetCookieExpDate {
# If the date string is formatted as: Wdy, DD-Mon-YYYY HH:MM:SS GMT, set #
# the $Cookie_Exp_Date to the new value and return 1 to signal success. #
# Otherwise, return 0, as the date was not successfully changed. #
# The date can also be set null value by calling: SetCookieExpDate(''). #
if ($_[0] =~ /^\w{3}\,\s\d{2}\-\w{3}-\d{4}\s\d{2}\:\d{2}\:\d{2}\sGMT$/ ||
$_[0] eq '') {
$Cookie_Exp_Date = $_[0];
return 1;
}
else {
return 0;
}
}
##############################################################################
# Subroutine: &SetCookie() #
# Returns: Nothing. #
##############################################################################
sub SetCookie {
my $cookie = $_[0];
my $value = $_[1];
my $char;
# We must translate characters which are not allowed in cookies. #
foreach $char (@Cookie_Encode_Chars) {
$cookie =~ s/$char/$Cookie_Encode_Chars{$char}/g;
$value =~ s/$char/$Cookie_Encode_Chars{$char}/g;
}
# Begin the printing of the Set-Cookie header with the cookie name #
# and value, followed by semi-colon. #
print 'Set-Cookie: ' . $cookie . '=' . $value . ';';
# If there is an Expiration Date set, add it to the header. #
if ($Cookie_Exp_Date) {
print ' expires=' . $Cookie_Exp_Date . ';';
}
# If there is a path set, add it to the header. #
if ($Cookie_Path) {
print ' path=' . $Cookie_Path . ';';
}
# If a domain has been set, add it to the header. #
if ($Cookie_Domain) {
print ' domain=' . $Cookie_Domain . ';';
}
print "\n";
}
##############################################################################
# Subroutine: &DelCookie #
# Description: Deletes specified cookie by setting the expiration date #
# 60 seconds in the past. #
# passed to subroutine. #
# Usage: &DelCookie(name) #
# Variables: name - Name of the cookie to be deleted. #
# Returns: Nothing. #
##############################################################################
sub DelCookie {
my $exptime;
my $cookie = $_[0];
$exptime = &Delta_GMT_Date( "-60S" );
if (&SetCookieExpDate($exptime)) {
&SetCookie( $cookie, "deleted" );
}
}
##############################################################################
# Subroutine: &Delta_GMT_Date #
# Description: Returns a valid formated GMT date str (for cookies) #
# based on string representing time change from the current #
# time. #
# Usage: $GMT_String = &Delta_GMT_Date( "+1Y" ); #
# Variables: Time Change String #
# Start Character: Operator ( +/- ) #
# Mid Character(s): Difference in Time units to calculate #
# Last Character: Time Unit ( Y,M,D,H,N, or S ) #
##############################################################################
sub Delta_GMT_Date {
my $in_str = $_[0];
local(@wdayvals) = ( "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" );
local(@months) = ( "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" );
local($cookie,$sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst,$new_year,$new_hour,$new_min,$new_sec);
my $oper;
my $num;
my $unit;
my %factor;
my $time;
my $newtime;
my $result;
$factor{ "Y" } = 31536000;
$factor{ "M" } = 2592000;
$factor{ "D" } = 86400;
$factor{ "H" } = 3600;
$factor{ "N" } = 60;
$factor{ "S" } = 1;
if ( $in_str =~ /^([\+\-])(\d+)([YMDHNS])$/i ) {
$oper = $1;
$num = $2 + 0;
$unit = uc( $3 );
if ( $oper eq "-" ) {
$newtime = time - ( $factor{ $unit } * $num );
}
else {
$newtime = time + ( $factor{ $unit } * $num );
}
}
else {
$newtime = time;
}
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime( $newtime );
$new_year = 1900 + $year;
$new_day = $mday; if ($mday < 10) { $new_day = "0$mday"; }
$new_hour = $hour; if ($hour < 10) { $new_hour = "0$hour"; }
$new_min = $min; if ($min < 10) { $new_min = "0$min"; }
$new_sec = $sec; if ($sec < 10) { $new_sec = "0$sec"; }
$result = "$wdayvals[$wday], $new_day-$months[$mon]-$new_year $new_hour:$new_min:$new_sec GMT";
return $result;
}