\n";
return $output;
}
sub get_time {
# --------------------------------------------------------
# Returns the time in the format "hh-mm-ss".
#
my ($sec, $min, $hour, $day, $mon, $year, $dweek, $dyear, $daylight) = localtime(time());
($sec < 10) and ($sec = "0$sec");
($min < 10) and ($min = "0$min");
($hour < 10) and ($hour = "0$hour");
return "$hour:$min:$sec";
}
sub get_date {
# --------------------------------------------------------
# Returns the date in the format "dd-mmm-yy".
# Warning: If you change the default format, you must also modify the &date_to_unix
# subroutine below which converts your date format into a unix time in seconds for sorting
# purposes.
my ($sec, $min, $hour, $day, $mon, $year, $dweek, $dyear, $daylight) = localtime(time());
my (@months) = qw!Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec!;
($day < 10) and ($day = "0$day");
$year = $year + 1900;
return "$day-$months[$mon]-$year";
}
sub date_to_unix {
# --------------------------------------------------------
# This routine must take your date format and return the time a la UNIX time().
# Some things to be careful about..
# int your values just in case to remove spaces, etc.
# catch the fatal error timelocal will generate if you have a bad date..
# don't forget that the month is indexed from 0!
#
my ($date) = $_[0];
my (%months) = ("Jan" => 0, "Feb" => 1, "Mar" => 2, "Apr" => 3, "May" => 4, "Jun" => 5,
"Jul" => 6, "Aug" => 7, "Sep" => 8, "Oct" => 9, "Nov" => 10,"Dec" => 11);
my ($time);
my ($day, $mon, $year) = split(/-/, $_[0]);
unless ($day and $mon and $year) { return undef; }
unless (defined($months{$mon})) { return undef; }
use Time::Local;
eval {
$day = int($day); $year = int($year) - 1900;
$time = timelocal(0,0,0,$day, $months{$mon}, $year);
};
if ($@) { return undef; } # Could return 0 if you want.
return ($time);
}
# These are the sorting functions used in &query.
# --------------------------------------------------------
sub alpha_ascend { lc($sortby{$a}) cmp lc ($sortby{$b}) }
sub alpha_descend { lc($sortby{$b}) cmp lc ($sortby{$a}) }
sub numer_ascend { $sortby{$a} <=> $sortby{$b} }
sub numer_descend { $sortby{$b} <=> $sortby{$a} }
sub date_ascend { &date_to_unix($sortby{$a}) <=> &date_to_unix($sortby{$b}) }
sub date_descend { &date_to_unix($sortby{$b}) <=> &date_to_unix($sortby{$a}) }
sub parse_form {
# --------------------------------------------------------
# Parses the form input and returns a hash with all the name
# value pairs. Removes SSI and any field with "---" as a value
# (as this denotes an empty SELECT field.
my (@pairs, %in);
my ($buffer, $pair, $name, $value);
if ($ENV{'REQUEST_METHOD'} eq 'GET') {
@pairs = split(/&/, $ENV{'QUERY_STRING'});
}
elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
@pairs = split(/&/, $buffer);
}
else {
&cgierr ("This script must be called from the Web\nusing either GET or POST requests\n\n");
}
PAIR: foreach $pair (@pairs) {
($name, $value) = split(/=/, $pair);
$name =~ tr/+/ /;
$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;
$value =~ s///g; # Remove SSI.
if ($value eq "---") { next PAIR; } # This is used as a default choice for select lists and is ignored.
(exists $in{$name}) ?
($in{$name} .= "~~$value") : # If we have multiple select, then we tack on
($in{$name} = $value); # using the ~~ as a seperator.
}
return %in;
}
sub cgierr {
# --------------------------------------------------------
# Displays any errors and prints out FORM and ENVIRONMENT
# information. Useful for debugging.
if (!$html_headers_printed) {
print "Content-type: text/html\n\n";
$html_headers_printed = 1;
}
print "DBMan encountered an internal error. ";
if ($db_debug) {
print "