# Formats a category name for displaying.
#
my ($input) = shift;
$input =~ s/_/ /g; # Change \'_\' to spaces.
$input =~ s,/, : ,g; # Change \'/\' to \' : \'.
return $input;
}
sub build_sorthit {
my (@unsorted) = @_;
my ($num) = ($#unsorted+1) / ($#db_cols+1);
my (%sortby, %isnew, %iscool, $hit, $i, @sorted);
for ($i = 0; $i < $num; $i++) {
$sortby{$i} = $unsorted[$db_sort_links + ($i * ($#db_cols+1))];
($unsorted[$db_isnew + ($i * ($#db_cols+1))] eq "Yes") and ($isnew{$i} = 1);
($unsorted[$db_ispop + ($i * ($#db_cols+1))] eq "Yes") and ($iscool{$i} = 1);
}
foreach $hit (sort {
($isnew{$b} and !$isnew{$a}) and return 1;
($isnew{$a} and !$isnew{$b}) and return -1;
($iscool{$b} and !$iscool{$a}) and return 1;
($iscool{$a} and !$iscool{$b}) and return -1;
($isnew{$a} and $isnew{$b}) and return lc($sortby{$a}) cmp lc($sortby{$b});
($iscool{$a} and $iscool{$b}) and return lc($sortby{$a}) cmp lc($sortby{$b});
return lc($sortby{$a}) cmp lc($sortby{$b});
} (keys %sortby)) {
$first = ($hit * $#db_cols) + $hit;
$last = ($hit * $#db_cols) + $#db_cols + $hit;
push (@sorted, @unsorted[$first .. $last]);
}
return @sorted;
}
sub urlencode {
# --------------------------------------------------------
#
my($toencode) = shift;
$toencode =~ s/([^a-zA-Z0-9_\\-.])/uc sprintf("%%%02x",ord($1))/eg;
$toencode =~ s/\\%2F/\\//g;
return $toencode;
}
sub get_date {
#
# Returns the current date.
#
my ($time) = shift;
$time ||= time();
exists $DATE_CACHE{$time} or ($DATE_CACHE{$time} = &unix_to_date($time));
return $DATE_CACHE{$time};
}
sub get_time {
# --------------------------------------------------------
# Returns the time in the format "hh-mm-ss".
#
my $time = shift;
$time ||= time();
my ($sec, $min, $hour, @junk) = 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 days_old {
# --------------------------------------------------------
# Returns the number of days from a given day to today (number of days
# old.
#
exists $DATE_CACHE{$_[0]} or ($DATE_CACHE{$_[0]} = &date_to_unix($_[0]));
return int ((time() - $DATE_CACHE{$_[0]}) / 86400);
}
sub compare_dates {
# --------------------------------------------------------
# Returns 1 if date a is greater then date b, otherwise returns 0.
#
exists $DATE_CACHE{$_[0]} or ($DATE_CACHE{$_[0]} = &date_to_unix($_[0]));
exists $DATE_CACHE{$_[1]} or ($DATE_CACHE{$_[1]} = &date_to_unix($_[1]));
return $DATE_CACHE{$_[0]} > $DATE_CACHE{$_[1]};
}
sub array_to_hash {
my ($hit, @array) = @_;
my ($i);
return map { $db_cols[$i] => $array[$hit * ($#db_cols+1) + $i++] } @_;
}
sub linewrap {
# --------------------------------------------------------
#
my $line = shift; defined $line or return \'\';
my @data = split /\\t/, $line;
my $columns = 60;
my $tabstop = 1;
my $frag = \'\';
my $col = $columns - 1;
for (@data) {
$_ = "$frag$_";
$frag = \'\';
s/(.{1,$columns}$)|(.{1,$col}(?:\\S\\s+|-(?=\\w)))|(.{$col})/
$3 ? "$3-\\n" :
$2 ? "$2\\n" :
(($frag = $1), \'\')
/ge;
$frag .= (\' \' x ($tabstop - length($frag) % $tabstop));
}
local $_ = join \'\', @data, $frag;
s/\\s+$//gm;
return $_;
}
sub load_template {
# --------------------------------------------------------
# Loads and parses a template. Expects to find as input a
# template file name, and a hash ref and optionally template text.
# If text is defined, then no file is loaded, but rather the template
# is taken from $text.
#
my ($tpl, $vars, $string) = @_;
(ref $vars eq \'HASH\') or &cgierr ("Not a hash ref: $vars in load_template!");
if (!defined $db_template) {
require "$db_lib_path/Template.pm";
$db_template = new Template ( { ROOT => $db_template_path, CHECK => 0 } );
}
$db_template->clear_vars;
$db_template->load_template ($tpl, $string) or &cgierr ("Can\'t load template. Reason: $Template::error");
$db_template->load_vars ($vars) or &cgierr ("Can\'t load variables. Reason: $Template::error");
return $db_template->parse ($tpl) or &cgierr ("Can\'t parse template. Reason: $Template::error");
}
sub join_encode {
# --------------------------------------------------------
# Takes a hash (ususally from the form input) and builds one
# line to output into the database. It changes all occurrences
# of the database delimeter to \'~~\' and all newline chars to \'``\'.
my %hash = @_;
my ($tmp, $col, $output);
foreach $col (@db_cols) {
$tmp = $hash{$col};
$tmp =~ s/^\\s+//g; # Trim leading blanks...
$tmp =~ s/\\s+$//g; # Trim trailing blanks...
$tmp =~ s/\\Q$db_delim\\E/~~/og; # Change delimeter to ~~ symbol.
$tmp =~ s/\\n/``/g; # Change newline to `` symbol.
$tmp =~ s/\\r//g; # Remove Windows linefeed character.
$output .= $tmp . $db_delim; # Build Output.
}
chop $output; # remove extra delimeter.
$output .= "\\n"; # add linefeed char.
return $output;
}
sub split_decode {
# --------------------------------------------------------
# Takes one line of the database as input and returns an
# array of all the values. It replaces special mark up that
# join_encode makes such as replacing the \'``\' symbol with a
# newline and the \'~~\' symbol with a database delimeter.
my ($input) = shift;
my (@array) = split (/\\Q$db_delim\\E/o, $input, $#db_cols+1);
foreach (@array) {
s/~~/$db_delim/g; # Retrieve Delimiter..
s/``/\\n/g; # Change \'\' back to newlines..
}
return @array;
}
sub html_print_headers {
# --------------------------------------------------------
# Print out the headers if they haven\'t already been printed.
#
if (!$html_headers_printed) {
print "HTTP/1.0 200 OK\\n" if ($db_iis or $nph);
print "Pragma: no-cache\\n" if ($db_nocache);
print "Content-type: text/html\\n\\n";
$html_headers_printed = 1;
}
}
sub parse_form {
# --------------------------------------------------------
# Parses the form input and returns a hash with all the name
# value pairs. Removes 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(\'You cant run this script from telnet/shell.\');
}
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 eq "---") and next PAIR;
exists $in{$name} ? ($in{$name} .= "~~$value") : ($in{$name} = $value);
}
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 "
\\n\\nCGI ERROR\\n==========================================\\n";
$_[0] and print "Error Message : $_[0]\\n";
$0 and print "Script Location : $0\\n";
$] and print "Perl Version : $]\\n";
print "\\nForm Variables\\n-------------------------------------------\\n";
foreach $key (sort keys %in) {
my $space = " " x (20 - length($key));
print "$key$space: $in{$key}\\n";
}
print "\\nEnvironment Variables\\n-------------------------------------------\\n";
foreach $env (sort keys %ENV) {
my $space = " " x (20 - length($env));
print "$env$space: $ENV{$env}\\n";
}
print "\\n
";
exit -1;
}
sub GK_category_list {
# --------------------------------------------------------
# Green Kakadu edit
# Returns a hash of all categories (and its nonenglish names) in the database.
my (%categories, @fields);
# Otherwise pull the list from the database.
open (DB, "<$db_category_name") or &cgierr("unable to open $db_file_name. Reason: $!");
if ($db_use_flock) { flock(DB, 1); }
LINE: while (
) {
(/^#/) and next LINE;
(/^\\s*$/) and next LINE;
@fields = &split_decode ($_);
$categories{$fields[$db_main_category]}=$fields[8]
;#см!
}
close DB;
return %categories;
}
1;
Что тут не так?
Каталог тестируется под виндоус а работать будет под юникс
Жду ответа....(а может вышлите?):-)
