1737 lines
62 KiB
Perl
1737 lines
62 KiB
Perl
# ==================================================================
|
|
# Gossamer Links - enhanced directory management system
|
|
#
|
|
# Website : http://gossamer-threads.com/
|
|
# Support : http://gossamer-threads.com/scripts/support/
|
|
# CVS Info : 087,071,086,086,085
|
|
# Revision : $Id: Tools.pm,v 1.198 2009/04/01 22:04:38 brewt Exp $
|
|
#
|
|
# Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved.
|
|
# Redistribution in part or in whole strictly prohibited. Please
|
|
# see LICENSE file for full details.
|
|
# ==================================================================
|
|
|
|
package Links::Tools;
|
|
# ==================================================================
|
|
use strict;
|
|
use Links qw/:objects :payment/;
|
|
use Links::Payment qw/COMPLETED/;
|
|
use vars qw/%STATUS_OK %STATUS_BAD %STATUS_NEW $LANGUAGE/;
|
|
|
|
%STATUS_OK = (
|
|
-99, "Default URL (http://)",
|
|
200, "OK 200",
|
|
201, "CREATED 201",
|
|
202, "Accepted 202",
|
|
203, "Partial Information 203",
|
|
302, "Found, but data resides under different URL (add a /)",
|
|
301, "Found, but moved",
|
|
303, "Method",
|
|
);
|
|
|
|
%STATUS_BAD = (
|
|
-1, "Could not lookup server",
|
|
-2, "Could not open socket",
|
|
-3, "Could not bind socket",
|
|
-4, "Could not connect",
|
|
-5, "Bad URL format",
|
|
-6, "Could not resolve host name",
|
|
-7, "ID could not be resolved",
|
|
-8, "Non parseable response",
|
|
204, "No Response 204",
|
|
304, "Not Modified",
|
|
400, "Bad request",
|
|
401, "Unauthorized",
|
|
402, "PaymentRequired",
|
|
403, "Forbidden",
|
|
404, "File Not found",
|
|
405, "Method Not Allowed",
|
|
407, "Unknown Request Method",
|
|
500, "Internal Error",
|
|
501, "Not implemented",
|
|
502, "Service temporarily overloaded",
|
|
503, "Gateway timeout ",
|
|
600, "Bad request",
|
|
601, "Not implemented",
|
|
602, "Connection failed (host not found?)",
|
|
603, "Timed out"
|
|
);
|
|
|
|
%STATUS_NEW = (
|
|
0, "New Link, UNCHECKED"
|
|
);
|
|
|
|
sub search_log {
|
|
# ------------------------------------------------------------------
|
|
# Display the keyword searches and perform purge if requested.
|
|
#
|
|
my $sl = $DB->table('SearchLogs');
|
|
my $days = $IN->param('days');
|
|
my %ret;
|
|
if (defined $days and $days =~ /^(?:\d+|\d*\.\d+)$/) {
|
|
my $cutoff = time - 86400 * $days;
|
|
$ret{num_logs_deleted} = $sl->delete(GT::SQL::Condition->new(slog_last => '<' => $cutoff));
|
|
$ret{logs_deleted} = defined $ret{num_logs_deleted};
|
|
}
|
|
|
|
my $sb = $IN->param('sb');
|
|
my $so = $IN->param('so');
|
|
my $nh = $IN->param('nh') || 1;
|
|
my $mh = $IN->param('mh') || 25;
|
|
unless ($sb) {
|
|
$IN->param(sb => $sb = 'slog_count');
|
|
$IN->param(so => $so = 'DESC');
|
|
}
|
|
my $sth = $sl->query_sth($IN);
|
|
my $hits = $sl->hits;
|
|
my $toolbar = $DB->html($sl, $IN)->toolbar($nh, $mh, $hits, $IN->url);
|
|
my $logs = $sth->fetchall_hashref;
|
|
for (@$logs) {
|
|
if ($_->{slog_time}) {
|
|
my $f = int(3 - (log $_->{slog_time}) / log 10);
|
|
$f = 6 if $f > 6;
|
|
$f = 0 if $f < 0;
|
|
$_->{slog_time_formatted} = sprintf("%.${f}fs", $_->{slog_time});
|
|
}
|
|
}
|
|
|
|
return {
|
|
%ret,
|
|
log_loop => $logs,
|
|
toolbar => $toolbar,
|
|
cgi_url => $CFG->{db_cgi_url},
|
|
sb => $sb, so => $so, nh => $nh, mh => $mh
|
|
}
|
|
}
|
|
|
|
sub status {
|
|
# ------------------------------------------------------------------
|
|
# Display the status of the links.
|
|
#
|
|
my $db = $DB->table('Links');
|
|
$db->select_options( "GROUP BY Status" );
|
|
my $sth = $db->select("Status", "COUNT(*)") or die "Query Error: $GT::SQL::error";
|
|
my ($good, $bad, $all, $new, $status);
|
|
$good = $bad = $all = $new = 0;
|
|
while (my ($s, $c) = $sth->fetchrow_array) {
|
|
CASE: {
|
|
exists $STATUS_OK{$s} and $good += $c, last CASE;
|
|
exists $STATUS_BAD{$s} and $bad += $c, last CASE;
|
|
$new += $c;
|
|
};
|
|
$all += $c;
|
|
$status->{$s} = $c;
|
|
}
|
|
my $out = '';
|
|
my $font = 'font face="Tahoma,Arial,Helvetica" size="2"';
|
|
foreach my $s (sort { $a <=> $b } keys %$status) {
|
|
$out .= qq!<tr><td><$font>!;
|
|
CASE: {
|
|
exists $STATUS_OK{$s} and ($out .= qq!<font color="green">$status->{$s}</font></td><td><a href="admin.cgi?do=page&page=tools_view_status.html&status=$s"><$font color="green">$STATUS_OK{$s}</font></a></td></tr>!), last CASE;
|
|
exists $STATUS_BAD{$s} and ($out .= qq!<font color="red">$status->{$s}</font></td><td><a href="admin.cgi?do=page&page=tools_view_status.html&status=$s"><$font color="red">$STATUS_BAD{$s}</font></a></td></tr>!), last CASE;
|
|
exists $STATUS_NEW{$s} and ($out .= $status->{$s} . qq!</td><td><a href="admin.cgi?do=page&page=tools_view_status.html&status=$s"><$font color="blue">$STATUS_NEW{$s}</font></a></td></tr>!), last CASE;
|
|
$out .= qq!<font color="red">$status->{$s}</font></td><td><a href="admin.cgi?do=page&page=tools_view_status.html&status=$s"><$font color="red">Unknown Error Code: $s</font></a></td></tr>!;
|
|
}
|
|
}
|
|
if (! $out) {
|
|
$out = qq!<tr><td><font face="Tahoma,Arial,Helvetica" size="2">0</font></td><td><font face="Tahoma,Arial,Helvetica" size="2">$STATUS_NEW{0}</font></td></tr>!;
|
|
}
|
|
return { Good => $good, Bad => $bad, All => $all, New => $new, Status => $out };
|
|
}
|
|
|
|
sub view_status {
|
|
# ------------------------------------------------------------------
|
|
# Displays a page of links based on status in table format.
|
|
#
|
|
my $db = $DB->table('Links');
|
|
my $vdb = $DB->table('Verify');
|
|
my $args = $IN->get_hash;
|
|
|
|
# First take care of any forced-validates.
|
|
if ($IN->param('validate')) {
|
|
foreach my $id ($IN->param('validate')) {
|
|
$vdb->delete( { LinkID => $id } );
|
|
$vdb->add({
|
|
LinkID => $id,
|
|
Status => 200,
|
|
Date_Checked => \'NOW()'
|
|
});
|
|
$db->update(
|
|
{ Status => 200 },
|
|
{ ID => $id }
|
|
);
|
|
}
|
|
}
|
|
|
|
# Now display the list of links.
|
|
my @status;
|
|
if ($IN->param('status') eq 'check_good') {
|
|
push @status, keys %STATUS_OK;
|
|
}
|
|
elsif ($IN->param('status') eq 'check_bad') {
|
|
push @status, keys %STATUS_BAD;
|
|
}
|
|
elsif ($IN->param('status') eq 'check_new') {
|
|
push @status, keys %STATUS_NEW;
|
|
}
|
|
elsif ($IN->param('status') eq 'check_all') {
|
|
push @status, keys %STATUS_BAD, keys %STATUS_OK, keys %STATUS_NEW;
|
|
}
|
|
else {
|
|
push @status, $IN->param('status');
|
|
}
|
|
|
|
@status or return { output => '', total => 0 };
|
|
|
|
my ($limit, $offset, $nh) = Links::limit_offset();
|
|
|
|
$db->select_options("ORDER BY Status, URL", "LIMIT $limit OFFSET $offset");
|
|
my $sth = $db->select(qw/ID URL Title Status/, { Status => \@status });
|
|
my $total = $db->hits;
|
|
my $old_status = '';
|
|
my $out = '';
|
|
|
|
my $base_validate_link = "admin.cgi?do=page&page=tools_view_status.html&nh=$nh&mh=$limit";
|
|
$base_validate_link .= join "", map "&status=$_", $IN->param("status");
|
|
|
|
while (my $link = $sth->fetchrow_hashref) {
|
|
if ($link->{Status} ne $old_status) {
|
|
my $name = $STATUS_OK{$link->{Status}} || $STATUS_BAD{$link->{Status}} || $STATUS_NEW{$link->{Status}};
|
|
$out .= <<HTML;
|
|
<tr><td colspan=2 bgcolor="#dddddd"><font face="Tahoma,Arial,Helvetica" size="2"><b>$link->{Status} - $name</b><br>
|
|
You can <a href="admin.cgi?do=delete_search_results&db=Links&Status=$link->{Status}">Delete</a> all entries with this status or
|
|
<a href="nph-verify.cgi?do=check_links&method=6&status=$link->{Status}">Recheck</a> all entries.
|
|
</td></tr>
|
|
HTML
|
|
$old_status = $link->{Status};
|
|
}
|
|
$vdb->select_options("ORDER BY Date_Checked DESC", "LIMIT 10");
|
|
my $sth2 = $vdb->select('Status', 'Date_Checked', { LinkID => $link->{ID} });
|
|
my $history;
|
|
while (my $verify = $sth2->fetchrow_hashref) {
|
|
if ($STATUS_OK{$verify->{Status}}) {
|
|
$history .= qq~$verify->{Date_Checked} - <font color="green">$verify->{Status}</font><br>~;
|
|
}
|
|
elsif ($STATUS_BAD{$verify->{Status}}) {
|
|
$history .= qq~$verify->{Date_Checked} - <font color="red">$verify->{Status}</font><br>~;
|
|
}
|
|
else {
|
|
$history .= qq~$verify->{Date_Checked} - $verify->{Status}<br>~;
|
|
}
|
|
}
|
|
$history = "<font face='Tahoma,Arial,Helvetica' size='2'>$history</font>";
|
|
|
|
my $eURL = $IN->html_escape($link->{URL});
|
|
my $eTitle = $IN->html_escape($link->{Title});
|
|
|
|
$out .= <<HTML;
|
|
<tr>
|
|
<td valign=top>
|
|
<font face='Tahoma,Arial,Helvetica' size='2'>
|
|
<input type="checkbox" name="delete" value="$link->{ID}">
|
|
<input type="hidden" name="$link->{ID}-ID" value="$link->{ID}">
|
|
$link->{ID} - <a href="$eURL">$eTitle</a> -
|
|
[
|
|
<a href="admin.cgi?do=modify_form&db=Links&modify=1&1-ID=$link->{ID}">Modify</a>
|
|
| <a href="nph-verify.cgi?do=check_links&method=7&ID=$link->{ID}">Recheck</a>
|
|
| <a href="$base_validate_link&validate=$link->{ID}">Validate</a>
|
|
]
|
|
</font>
|
|
</td>
|
|
<td valign=top>$history</td>
|
|
</tr>
|
|
HTML
|
|
}
|
|
my $url = $IN->url;
|
|
my $html = $DB->html(['Links'], $IN);
|
|
my $toolbar = $html->toolbar($nh, $limit, $total, $url);
|
|
|
|
return { output => $out, toolbar => $toolbar, total => $total };
|
|
}
|
|
|
|
sub check_duplicates {
|
|
# ------------------------------------------------------------------
|
|
# Displays a list of duplicate URL's.
|
|
#
|
|
my $db = $DB->table('Links');
|
|
my $nh = $IN->param('nh') || 1;
|
|
my $mh = $IN->param('mh') || 10;
|
|
my $begin = ($nh - 1) * $mh;
|
|
my $end = $begin + $mh;
|
|
|
|
# We turn on big tables as this is usually a large query for MySQL.
|
|
if (lc $db->{connect}->{driver} eq 'mysql') {
|
|
my $sth = $db->prepare("SET OPTION SQL_BIG_TABLES = 1");
|
|
$sth->execute;
|
|
}
|
|
|
|
# Now get URL's and Counts.
|
|
$db->select_options("GROUP BY URL", "ORDER BY hits DESC");
|
|
my $sth = $db->select('URL', 'COUNT(*) AS hits', GT::SQL::Condition->new('URL', '<>', "", 'URL', '<>', 'http://'));
|
|
my $row_num = -1;
|
|
my $total = 0;
|
|
my $dupes = '';
|
|
my %seen;
|
|
while (my ($url, $count) = $sth->fetchrow_array) {
|
|
last if ($count == 1);
|
|
$total += $count;
|
|
$row_num++;
|
|
$seen{$url} = 1;
|
|
next if ($row_num < $begin);
|
|
last if ($row_num >= $end);
|
|
|
|
my $eurl = $IN->html_escape($url);
|
|
my $sth2 = $db->select('ID', 'Title', { URL => $url });
|
|
$dupes .= qq~
|
|
<tr><td bgcolor="#dddddd">
|
|
<font face="Tahoma,Arial,Helvetica" size="2"><b>$eurl - $count</b></font>
|
|
</td></tr>
|
|
~;
|
|
while (my ($id, $title) = $sth2->fetchrow_array) {
|
|
my $cats = $db->get_categories($id);
|
|
my ($cid, $cname) = each %$cats;
|
|
my $etitle = $IN->html_escape($title);
|
|
|
|
$dupes .= qq~
|
|
<tr><td valign=top>
|
|
<font face="Tahoma,Arial,Helvetica" size="2">
|
|
<input type="checkbox" name="delete" value="$id">
|
|
<input type="hidden" name="$id-ID" value="$id">
|
|
$id - <a href="$eurl">$etitle</a> - $cname -
|
|
[ <a href="admin.cgi?do=modify_form&db=Links&modify=1&1-ID=$id">Modify</a> ]
|
|
</font>
|
|
</td></tr>
|
|
~;
|
|
}
|
|
}
|
|
while (my ($url, $count) = $sth->fetchrow_array) {
|
|
last if ($count == 1);
|
|
$seen{$url} = 1;
|
|
$total += $count;
|
|
}
|
|
my $url = $IN->url;
|
|
my $html = $DB->html(['Links'], $IN);
|
|
my $hits = scalar keys %seen;
|
|
my $toolbar = $html->toolbar($nh, $mh, $hits, $url);
|
|
|
|
return { total => $total, output => $dupes, toolbar => $toolbar, number_urls => $hits };
|
|
}
|
|
|
|
sub check_links {
|
|
# ------------------------------------------------------------------
|
|
# Takes a list of Link IDs for checking and returns a hash ref
|
|
# of results (will also update the database)
|
|
#
|
|
my @ids = @_;
|
|
|
|
my $links = $DB->table('Links');
|
|
my %results;
|
|
|
|
# Returns the integer http status of the link
|
|
my $check_func = sub {
|
|
my $link = shift;
|
|
my $status = link_status($link->{URL});
|
|
# Let parent process know what's up
|
|
print "$link->{ID}\t$status\t$link->{URL}\n";
|
|
return $status;
|
|
};
|
|
|
|
for my $id (@ids) {
|
|
my $sth = $links->select('ID', 'URL', { ID => $id });
|
|
# With all the concurrent requests, some databases may limit the queries, so
|
|
# check to make sure the select was successful.
|
|
unless ($sth) {
|
|
warn "Error fetching link ($id): $GT::SQL::error";
|
|
$results{$id} = undef;
|
|
next;
|
|
}
|
|
my $link = $sth->fetchrow_hashref;
|
|
unless ($link) {
|
|
warn "Error fetching link: no link with ID, $id, exists";
|
|
$results{$id} = undef;
|
|
next;
|
|
}
|
|
$results{$id} = $PLG->dispatch('check_link', $check_func, $link);
|
|
}
|
|
|
|
return \%results;
|
|
}
|
|
|
|
sub link_status {
|
|
# ------------------------------------------------------------------
|
|
# Returns an HTTP code on trying to reach the URL
|
|
#
|
|
my $url = shift or return;
|
|
$url =~ /^\w+\:.+/ or return;
|
|
if ($url =~ /^https?/i) {
|
|
return -99 if $url eq 'http://'; # The default url
|
|
return -5 unless $url =~ /https?\:\/\/[\w-]+\..+/i;
|
|
|
|
require GT::WWW;
|
|
|
|
my $www = new GT::WWW;
|
|
eval {
|
|
$www->url($url);
|
|
} or return -5;
|
|
|
|
my $response;
|
|
eval {
|
|
local $SIG{ALRM} = sub { die "time out\n" };
|
|
alarm(30);
|
|
# We're handling connection timeouts ourselves (GT::Socket sets an alarm, so we
|
|
# don't want it to set another alarm).
|
|
$www->connection_timeout(0);
|
|
$response = $www->head;
|
|
alarm(0);
|
|
};
|
|
|
|
if ($@ and $@ eq "time out\n") {
|
|
return -4;
|
|
}
|
|
|
|
# Could not connect for some reason or the server returned an invalid response
|
|
return -4 unless $response;
|
|
|
|
# If the HEAD request fails, attempt a GET request. On some misconfigured
|
|
# servers, a HEAD request will erroneously return a 4xx error.
|
|
unless ($response->status) {
|
|
# We don't care about the body of the page, so cancel the request
|
|
# as soon as we start getting the body:
|
|
$www->chunk_size(1);
|
|
$www->chunk(sub { $www->cancel });
|
|
$response = $www->get;
|
|
}
|
|
|
|
return -4 unless $response;
|
|
|
|
return int $response->status;
|
|
}
|
|
elsif ($url =~ /^ftp/i) {
|
|
eval { require Net::FTP };
|
|
|
|
$@ and return;
|
|
|
|
return unless $url =~ m,^ftp://(?:([^:]+):([^@]+)@)?([^/:]+):?(\d*)(.*)$,i;
|
|
|
|
my ($user, $pass, $host, $port, $path) = ($1, $2, $3, $4, $5);
|
|
|
|
$host or return -5;
|
|
gethostbyname($host) or return -6;
|
|
|
|
$path ||= '/';
|
|
$port ||= 21;
|
|
$user ||= 'anonymous';
|
|
$pass ||= $CFG->{db_admin_email};
|
|
|
|
my $ftp = Net::FTP->new($host) or return -4;
|
|
$ftp->login($user, $pass) or return 401;
|
|
$ftp->mdtm($path) or return 404;
|
|
$ftp->quit;
|
|
|
|
return 200;
|
|
}
|
|
else {
|
|
return 407;
|
|
}
|
|
}
|
|
|
|
sub expired_links_purge {
|
|
# -------------------------------------------------------------------
|
|
# Purge expired links .
|
|
#
|
|
if ($IN->param('expired_links_purge')) {
|
|
my $purge_days = $IN->param('purge_days');
|
|
$purge_days = time - $purge_days * 24 * 60 * 60;
|
|
my $tb = $DB->table('Links');
|
|
my $cond = new GT::SQL::Condition(ExpiryDate => '>' => UNPAID, ExpiryDate => '<' => $purge_days);
|
|
my $cnt = $tb->count($cond);
|
|
$cnt or return { error => 'No links to delete' };
|
|
my $results = $tb->delete($cond);
|
|
return { del_num => $cnt, message => "$cnt expired links have been purged" };
|
|
}
|
|
else { return }
|
|
}
|
|
|
|
sub parse_format {
|
|
# -----------------------------------------------------------------------------
|
|
# Takes a format and hash of x => value pairs, where x can be any combination
|
|
# of letters and numbers.
|
|
#
|
|
# Formats are as follows:
|
|
# %x% - the value - this may also be a pipe (|) separated list of possible keys
|
|
# to use as the value, where the first non-zero length value is used
|
|
# %20-15x% - if x is longer than 35 (20+15), this returns the first 20
|
|
# characters followed by the last 15 characters
|
|
# %20x% - if x is longer than 20, this returns the first 20
|
|
# %-20x% - if x is longer than 20, this returns the last 20
|
|
# %20-15x/% - just like the versions above, except if the path contains /'s,
|
|
# the shortening applied to each part of the path, rather than the
|
|
# entire value.
|
|
# %20x/% - see %20-15x/%
|
|
# %-20x/% - see %20-15x/%
|
|
#
|
|
# Additionally, any of the formats above can be have (...) at the beginning -
|
|
# if present, instead of removing the excess values, the removed section will
|
|
# be replaced with whatever is inside the ( ).
|
|
#
|
|
# Using these rules, a pattern of '%(--)10-3Full_Name/%' would convert a
|
|
# 'Full_Name' value of:
|
|
#
|
|
# Long_Name_Category_1/Some_Other_Category_foo/another_cat_BAR
|
|
#
|
|
# into:
|
|
#
|
|
# Long_Name_--y_1/Some_Other--foo/another_cat_BAR
|
|
#
|
|
# Additionally, if a 'clean' key and value are passed in, path sanitization
|
|
# will be performed on the value. Specifically, any "." preceded by a "/" or
|
|
# "\", or at the beginning of the string, will be turned into "_".
|
|
#
|
|
my ($format, %opts) = @_;
|
|
|
|
my $clean = delete $opts{clean};
|
|
|
|
for (keys %opts) {
|
|
length and not /\W/ or die "Invalid format parameter '$_': Only letters and numbers are permitted.";
|
|
$opts{$_} =~ y{A-Za-z0-9./-}{_}cs if $opts{$_};
|
|
}
|
|
my $p = join '|', keys %opts;
|
|
$format =~ s{
|
|
%
|
|
(?:
|
|
\(([\w.-]+)\) # leading (...) ($1)
|
|
)?
|
|
(?:
|
|
( # Allows 10- and - in 10-10x and -10x ($2)
|
|
(\d+)? # ($3)
|
|
-
|
|
)?
|
|
(\d+) # allows 10 in 10x ($4)
|
|
)?
|
|
((?:$p)(?:\|(?:$p))*) # The value to go here from %opts, above ($5)
|
|
(/)? # trailing / means that the numbers above get applied to each path component, instead of the whole thing ($6)
|
|
%
|
|
}{
|
|
my $ellipsis = $1 || '';
|
|
my ($begin, $end) = defined($2) ? ($3 || 0, $4) : ($4, 0);
|
|
my $val = $5;
|
|
my @vals = split(/\|/, $5);
|
|
for (@vals) {
|
|
if (exists $opts{$_} and defined $opts{$_} and length $opts{$_}) {
|
|
$val = $opts{$_};
|
|
last;
|
|
}
|
|
}
|
|
# We only need to start chopping things up if $begin or $end is set
|
|
if ($begin or $end) {
|
|
my @components = $6 ? (split m{/}, $val, -1) : $val;
|
|
for (@components) {
|
|
if (length > ($begin + $end + length $ellipsis)) {
|
|
my $c = '';
|
|
$c .= substr($_, 0, $begin) if $begin;
|
|
$c .= $ellipsis;
|
|
$c .= substr($_, -$end) if $end;
|
|
$_ = $c;
|
|
}
|
|
}
|
|
$val = join '/', @components;
|
|
}
|
|
$val
|
|
}egx;
|
|
|
|
$format =~ s{(^|[/\\])\.}{${1}_}g if $clean;
|
|
$format;
|
|
}
|
|
|
|
sub language_editor {
|
|
# ------------------------------------------------------------------
|
|
# Loads the language file editor.
|
|
#
|
|
my $selected_dir = Links::template_set($IN->param('tpl_dir'));
|
|
|
|
my $dir = "$CFG->{admin_root_path}/templates/$selected_dir";
|
|
my $file = 'language.txt';
|
|
my $lang = GT::Config->load("$dir/$file", { create_ok => 1, inheritance => 1, local => 1, cache => 1 });
|
|
my $font = 'face="Tahoma,Arial,Helvetica" size="2"';
|
|
my $message;
|
|
if ($IN->param('save')) {
|
|
|
|
if (-e "$dir/$file" and ! -w _) {
|
|
$message = "Unable to overwrite file: $file (permission denied). Please set permissions properly and save again.";
|
|
}
|
|
elsif (! -e _ and ! -w $dir) {
|
|
$message = "Unable to create new files in directory $selected_dir. Please set permissions properly and save again.";
|
|
}
|
|
else {
|
|
foreach my $code ($IN->param()) {
|
|
next unless ($code =~ /^save-(.*)/);
|
|
my $key = $1;
|
|
if ($IN->param("del-$key")) {
|
|
delete $lang->{$key};
|
|
next;
|
|
}
|
|
my $orig = $IN->param("orig-$key");
|
|
my $var = $IN->param($code);
|
|
next if $orig eq $var;
|
|
$var =~ s/\r?\n/\n/g; # Remove windows linefeeds.
|
|
$lang->{$key} = $var;
|
|
}
|
|
if (my $val = $IN->param('new') and my $var = $IN->param('new-val')) {
|
|
$var =~ s/\r?\n/\n/g;
|
|
$lang->{$val} = $var;
|
|
}
|
|
$lang->save;
|
|
$message = "Changes saved successfully.";
|
|
}
|
|
}
|
|
|
|
# Reload the language file (you can't delete language from the inherited language.txt)
|
|
$lang = GT::Config->load("$dir/$file", { create_ok => 1, inheritance => 1, local => 1, cache => 1 });
|
|
|
|
# Load the language file.
|
|
my $prefix = $IN->param('prefix');
|
|
my %prefix_list;
|
|
my $table = "<table border=0 width=100%><tr><td><font $font><b>Code</b></font></td><td><font $font><b>Description</b></font></td><td><font $font><b>Delete</b></font></td></tr>";
|
|
foreach my $code (sort keys %$lang) {
|
|
if ($code =~ /^([^_]+)_/) {
|
|
$prefix_list{$1}++;
|
|
}
|
|
next if $prefix and $code !~ /^${prefix}_/;
|
|
my $str = $IN->html_escape($lang->{$code});
|
|
$table .= qq~<tr><td valign=top><font $font>$code</font></td><td><input type="hidden" name="orig-$code" value="$str"><textarea rows=5 cols=40 name='save-$code'>$str</textarea></td><td><input type=checkbox name="del-$code" value="1"></td></tr>~;
|
|
}
|
|
$table .= qq~<tr><td valign=top><nobr><font $font>New: <input name="new" size=10 value=""></font></nobr></td><td><textarea rows=5 cols=40 name='new-val'></textarea></td><td> </td></tr></table>~;
|
|
|
|
my $prefix_output;
|
|
foreach my $prefix (sort keys %prefix_list) {
|
|
$prefix_output .= qq~
|
|
<a href="admin.cgi?do=page&page=build_lang.html&prefix=$prefix&tpl_dir=$selected_dir">$prefix ($prefix_list{$prefix})</a> |~;
|
|
}
|
|
chop $prefix_output if ($prefix_output);
|
|
|
|
return { language_table => $table, message => $message, prefix_list => $prefix_output };
|
|
}
|
|
|
|
sub global_editor {
|
|
# ------------------------------------------------------------------
|
|
# Loads the global template vars.
|
|
#
|
|
my $selected_dir = Links::template_set($IN->param('tpl_dir'));
|
|
|
|
my $dir = "$CFG->{admin_root_path}/templates/$selected_dir";
|
|
my $file = 'globals.txt';
|
|
my $globals = GT::Config->load("$dir/$file", { create_ok => 1, inheritance => 1, local => 1, cache => 1 });
|
|
my $font = 'face="Tahoma,Arial,Helvetica" size="2"';
|
|
my $message;
|
|
if ($IN->param('save')) {
|
|
|
|
if (-e "$dir/$file" and ! -w _) {
|
|
$message = "Unable to overwrite file: $file (permission denied). Please set permissions properly and save again.";
|
|
}
|
|
elsif (! -e _ and ! -w $dir) {
|
|
$message = "Unable to create new files in directory $selected_dir. Please set permissions properly and save again.";
|
|
}
|
|
else {
|
|
my @param = $IN->param();
|
|
foreach my $code (@param) {
|
|
next unless ($code =~ /^save-(.*)/);
|
|
my $key = $1;
|
|
if ($IN->param("del-$key")) {
|
|
delete $globals->{$key};
|
|
next;
|
|
}
|
|
my $orig = $IN->param("orig-$key");
|
|
my $var = $IN->param($code);
|
|
next if $orig eq $var;
|
|
$var =~ s/\r\n/\n/g; # Remove windows linefeeds.
|
|
$globals->{$key} = $var;
|
|
}
|
|
|
|
my $val = $IN->param('new') || '';
|
|
$val =~ s/^\s+//;
|
|
$val =~ s/\s+$//;
|
|
if (length $val) {
|
|
my $var = $IN->param('new-val');
|
|
$var =~ s/\r\n/\n/g;
|
|
$globals->{$val} = $var;
|
|
}
|
|
|
|
$globals->save;
|
|
$message = "Changes saved successfully.";
|
|
}
|
|
}
|
|
|
|
# Reload the globals file (you can't delete globals from the inherited globals.txt)
|
|
$globals = GT::Config->load("$dir/$file", { create_ok => 1, inheritance => 1, local => 1, cache => 1 });
|
|
|
|
# Load the globals file.
|
|
my $table = "<table border=0 width=100%><tr><td><font $font><b>Code</b></font></td><td><font $font><b>Description</b></font></td><td><font $font><b>Delete</b></font></td></tr>";
|
|
for my $code (sort keys %$globals) {
|
|
my $str = $IN->html_escape($globals->{$code});
|
|
$table .= qq~<tr><td valign=top><font $font>$code</font></td><td><input type="hidden" name="orig-$code" value="$str"><textarea rows=5 cols=40 name='save-$code' wrap="off">$str</textarea></td><td><input type=checkbox name="del-$code" value="1"></td></tr>~;
|
|
}
|
|
$table .= qq~<tr><td valign=top><nobr><font $font>New: <input name="new" size=10 value=""></font></nobr></td><td><textarea wrap="off" rows=5 cols=40 name='new-val'></textarea></td><td> </td></tr></table>~;
|
|
|
|
return { global_table => $table, message => $message };
|
|
}
|
|
|
|
sub template_editor {
|
|
# ------------------------------------------------------------------
|
|
# Loads the template editor.
|
|
#
|
|
require GT::Template::Editor;
|
|
Links::init_date();
|
|
my $demo = 0;
|
|
|
|
my $editor = new GT::Template::Editor (
|
|
root => $CFG->{admin_root_path} . '/templates',
|
|
# The template set/files dropdowns generated from this aren't used anymore, tpl_{dir,file}_select are used instead
|
|
default_dir => scalar Links::template_set(),
|
|
backup => 1,
|
|
cgi => $IN,
|
|
date_format => $CFG->{date_user_format} . ' %hh%:%mm%:%ss%',
|
|
skip_file => ['README', 'globals.txt', 'language.txt', '*.eml'],
|
|
demo => $demo
|
|
);
|
|
return $editor->process;
|
|
}
|
|
|
|
sub css_editor {
|
|
# ------------------------------------------------------------------
|
|
# Provide admin CSS editor functionality
|
|
#
|
|
my %opts = @_;
|
|
|
|
if (not $opts{css_dir} or $opts{css_dir} !~ /^[\w-]+$/) {
|
|
return { error => Links::language('CSSEDITOR_INVALID_TPL') };
|
|
}
|
|
if (not $opts{css_file} or $opts{css_file} !~ /^[\w-]+\.css$/i) {
|
|
return { error => Links::language($opts{action} eq 'save' ? 'CSSEDITOR_INVALID_FILENAME' : 'CSSEDITOR_INVALID_CSS') };
|
|
}
|
|
if ($opts{demo} and $opts{action} ne 'load') {
|
|
return { error => "You cannot $opts{action} files in the demo." };
|
|
}
|
|
|
|
my $css_path = "$CFG->{build_static_path}/$opts{css_dir}/$opts{css_file}";
|
|
if ($opts{action} eq 'load') {
|
|
open CSS, $css_path or return { error => $! };
|
|
my $css;
|
|
{
|
|
local $/;
|
|
$css = <CSS>;
|
|
}
|
|
close CSS;
|
|
return { css => $css };
|
|
}
|
|
elsif ($opts{action} eq 'save') {
|
|
if (-e $css_path and -f _) {
|
|
require GT::File::Tools;
|
|
GT::File::Tools::copy($css_path, "$css_path.bak");
|
|
}
|
|
open CSS, ">$css_path" or return { error => $! };
|
|
print CSS $opts{css};
|
|
close CSS;
|
|
}
|
|
elsif ($opts{action} eq 'delete') {
|
|
unlink $css_path or return { error => $! };
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub template_dir_select {
|
|
# ------------------------------------------------------------------
|
|
# Returns a select list of template directories.
|
|
# This function is deprecated (it does not support themes), use tpl_dir_select instead.
|
|
#
|
|
my ($dir, $file, @dirs);
|
|
ref $_[0] and shift; # Can be called from a template where first argument is a hash ref of tags.
|
|
my $selected_dir = shift || $CFG->{build_default_tpl} || 'luna';
|
|
my $name = shift || 'tpl_dir';
|
|
|
|
$dir = $CFG->{admin_root_path} . "/templates";
|
|
opendir TPL, $dir or die "unable to open directory: '$dir' ($!)";
|
|
while (defined($file = readdir TPL)) {
|
|
push @dirs, $file unless
|
|
$file =~ /^\.\.?$/ or
|
|
$file eq 'admin' or $file eq 'browser' or $file eq 'help' or $file eq 'CVS' or
|
|
not -d "$dir/$file";
|
|
}
|
|
closedir TPL;
|
|
|
|
my $d_select_list = qq'<select name="$name">';
|
|
foreach (sort @dirs) {
|
|
$d_select_list .= $selected_dir eq $_ ? "<option selected>$_</option>" : "<option>$_</option>";
|
|
}
|
|
$d_select_list .= "</select>";
|
|
return $d_select_list;
|
|
}
|
|
|
|
sub tpl_dir_select {
|
|
# ----------------------------------------------------------------------
|
|
# Returns the template loop variable 'dir_select' with iteration value:
|
|
# directory - the name of the directory
|
|
# $mask is a regex of the templates that you don't wish to show
|
|
# $unmask is a regex of the templates that you only want to show
|
|
# $show_themes is whether or not to show themes in the template listing
|
|
#
|
|
my ($selected, $mask, $unmask, $show_themes) = @_;
|
|
if ($show_themes) {
|
|
$selected ||= join('.', Links::template_set($selected));
|
|
}
|
|
else {
|
|
$selected ||= Links::template_set($selected);
|
|
}
|
|
|
|
my @dirs;
|
|
my $dir = "$CFG->{admin_root_path}/templates";
|
|
local *TPL;
|
|
opendir TPL, $dir or die "unable to open directory: '$dir' ($!)";
|
|
for (sort { lc $a cmp lc $b } readdir TPL) {
|
|
next if $_ =~ /\./ or $_ eq 'CVS' or ($mask and m/^$mask$/i) or ($unmask and not m/^$unmask$/i) or not -d "$dir/$_";
|
|
my $theme_found = 0;
|
|
if ($show_themes) {
|
|
my $themedir = "$CFG->{build_static_path}/$_";
|
|
if (-d $themedir) {
|
|
opendir THEMES, $themedir or die "unable to open static directory: '$themedir' ($!)";
|
|
while (my $theme = readdir THEMES) {
|
|
next if $theme !~ /.+\.css$/ or $theme =~ /_core\.css$/ or
|
|
not -f "$themedir/$theme";
|
|
|
|
$theme =~ s/\.css$//;
|
|
my %dir = (directory => $theme eq $_ ? $_ : "$_.$theme");
|
|
$dir{dir_selected} = $dir{directory} eq $selected;
|
|
push @dirs, \%dir;
|
|
$theme_found++;
|
|
}
|
|
closedir THEMES;
|
|
}
|
|
}
|
|
|
|
if (not $theme_found) {
|
|
push @dirs, { directory => $_, dir_selected => $_ eq $selected };
|
|
}
|
|
}
|
|
closedir TPL;
|
|
|
|
return { template_set_loop => \@dirs };
|
|
}
|
|
|
|
# Returns 0 or 1 - 1 means the template is okay. Takes full path, filename, and
|
|
# mask (optional) as arguments.
|
|
sub _is_template {
|
|
my ($dir, $file, $mask, $unmask) = @_;
|
|
return 0 if
|
|
substr($file, -4) eq '.bak' or
|
|
not -f "$dir/$file" or
|
|
not -r _ or
|
|
$file eq 'README' or $file eq 'language.txt' or $file eq 'globals.txt' or
|
|
($mask and $file =~ /^$mask$/i) or ($unmask and $file !~ /^$unmask$/i);
|
|
return 1;
|
|
}
|
|
|
|
sub tpl_file_select {
|
|
# -------------------------------------------------------------------------
|
|
# Returns the template loop variable 'file_select' with iteration values:
|
|
# filename - the filename
|
|
# local - Indicates a 'local' file.
|
|
# If local set: new_local - Indicates a local file without a system file
|
|
#
|
|
my ($template, $mask, $unmask) = @_;
|
|
$template = Links::template_set($template) unless $template eq 'admin';
|
|
|
|
my $dir = "$CFG->{admin_root_path}/templates/$template";
|
|
local *TPL;
|
|
my %files;
|
|
if (opendir TPL, "$dir/local") {
|
|
%files = map { _is_template("$dir/local", $_, $mask, $unmask) ? ($_ => 2) : () } readdir TPL;
|
|
closedir TPL;
|
|
}
|
|
opendir TPL, $dir or die "Unable to open directory '$dir': $!";
|
|
for (readdir TPL) {
|
|
next unless _is_template($dir, $_, $mask, $unmask);
|
|
$files{$_}++;
|
|
}
|
|
closedir TPL;
|
|
|
|
# %file now has keys of filenames, and values of: 1 => system, 2 => local, 3 => both
|
|
return { template_loop => [map +{ filename => $_, $files{$_} >= 2 ? (local => 1, new_local => $files{$_} == 3) : (local => 0) }, sort { lc $a cmp lc $b } keys %files] };
|
|
}
|
|
|
|
sub file_select {
|
|
# -------------------------------------------------------------------------
|
|
# Returns a file_loop variable containing the files/directories in the directory
|
|
# that match the masks.
|
|
#
|
|
# $mask is a regex of the files/directories that you don't wish to show
|
|
# $unmask is a regex of the files/directories that you only want to show
|
|
# $type is either 'f' (show only files) or 'd' (show only directories) or empty
|
|
# (show both files and directories)
|
|
#
|
|
my ($dir, $mask, $unmask, $type) = @_;
|
|
|
|
return { file_loop => [] } unless -d $dir;
|
|
|
|
my @files;
|
|
opendir DIR, $dir or die "Unable to open directory '$dir': $!";
|
|
for (sort { lc $a cmp lc $b } readdir DIR) {
|
|
next if ($mask and m/^$mask$/i) or ($unmask and not m/^$unmask$/i) or
|
|
($type eq 'f' and not -f "$dir/$_") or ($type eq 'd' and not -d "$dir/$_");
|
|
push @files, $_;
|
|
}
|
|
closedir DIR;
|
|
|
|
return { file_loop => \@files };
|
|
}
|
|
|
|
sub editor_size {
|
|
# ------------------------------------------------------------------
|
|
# Sets the editor default size.
|
|
#
|
|
my $editor_rows = $IN->param('cookie-editor_rows') || $IN->cookie('editor_rows') || 20;
|
|
my $editor_cols = $IN->param('cookie-editor_cols') || $IN->cookie('editor_cols') || 75;
|
|
return { editor_rows => $editor_rows, editor_cols => $editor_cols };
|
|
}
|
|
|
|
sub highlight {
|
|
# -------------------------------------------------------------------
|
|
#
|
|
my ($str, $q) = @_;
|
|
(my $query = $q) =~ y/A-Z+"'-/a-z/d;
|
|
|
|
my $i;
|
|
my %term;
|
|
for (split ' ', $query) {
|
|
my $lc = lc;
|
|
$term{$lc} = ($i++ % $CFG->{search_highlight_colors}) + 1 unless exists $term{$lc};
|
|
}
|
|
return $str unless keys %term;
|
|
|
|
my @pieces = split /((?:\s*<(?:[^>'"]|"[^"]*"|'[^']*')*>)+\s*|\s+)/, $str;
|
|
my $re = join '|', map quotemeta, keys %term;
|
|
for $i (0 .. int($#pieces / 2)) {
|
|
$pieces[2 * $i] =~ s{($re)}{<span class="searchhl-$term{lc $1}">$1</span>}gi;
|
|
}
|
|
return join '', @pieces;
|
|
}
|
|
|
|
sub validate_links {
|
|
# ------------------------------------------------------------------
|
|
# Display a list of links waiting to be validated.
|
|
#
|
|
my $db = $DB->table('Links');
|
|
my $cat_link = $DB->table('CatLinks');
|
|
my $user_db = $DB->table('Users');
|
|
my $html = $DB->html( $db, $IN );
|
|
my $font = 'font face="Tahoma,Arial,Helvetica" size="1"';
|
|
my $nh = $IN->param('nh') || 1;
|
|
my $mh = $IN->param('mh') || 5;
|
|
|
|
# Process any actions.
|
|
my $results = _validate($db);
|
|
|
|
# Clear our cgi so we don't cause conflicts.
|
|
$html->{input} = {};
|
|
|
|
# Get a list of links awaiting validation.
|
|
my $sth = $db->query_sth({
|
|
isValidated => 'No',
|
|
mh => $mh,
|
|
nh => $nh,
|
|
sb => 'Add_Date',
|
|
so => 'DESC'
|
|
});
|
|
my $total = $db->hits;
|
|
my $i = 0;
|
|
|
|
my $output = '';
|
|
Links::init_date();
|
|
my $today = GT::Date::date_get();
|
|
while (my $link = $sth->fetchrow_hashref) {
|
|
$i++;
|
|
my $user = $user_db->get($link->{LinkOwner}) || {};
|
|
$link->{'CatLinks.CategoryID'} = [$cat_link->select('CategoryID', { LinkID => $link->{ID} })->fetchall_list];
|
|
|
|
# Load reason before setting the Add_Date/Mod_Date to today.
|
|
my $reason = Links::send_email('link_rejected.eml', { %$user, %$link }, { get_body => 1 });
|
|
|
|
# Set Add_Date/Mod_Date, so if the link gets validated, it gets set to the current date.
|
|
$link->{Add_Date} = $today if $CFG->{link_validate_date};
|
|
$link->{Mod_Date} = $today;
|
|
my $form = $html->form({ values => $link, extra_table => 0, mode => 'validate', view_key => 1, multiple => $i, file_field => 1, file_delete => 1 });
|
|
|
|
my $eURL = $IN->html_escape($link->{URL});
|
|
|
|
$output .= <<HTML;
|
|
<table border=1 cellpadding=0 cellspacing=0 width=500>
|
|
<tr><td>$form</td></tr>
|
|
<tr><td>
|
|
<table border=0 cellpadding=3 cellspacing=2 width="100%">
|
|
<tr>
|
|
<td valign=top>
|
|
<$font>
|
|
<input type="radio" name="validate-$link->{ID}" value="" onclick="checkValidate()" id="validate-$link->{ID}-nothing" checked>
|
|
<label for="validate-$link->{ID}-nothing">Do nothing</label>
|
|
</font>
|
|
</td>
|
|
<td valign=top>
|
|
<$font>
|
|
<input type="radio" name="validate-$link->{ID}" value="validate" onclick="checkValidate()" id="validate-$link->{ID}-validate">
|
|
<label for="validate-$link->{ID}-validate">Validate</label>
|
|
(<a href="$eURL" target="validate">view</a> |
|
|
<a href="admin.cgi?db=Links&do=search_results&URL=$eURL&URL-opt=LIKE&isValidated=Yes" target="duplicate">check</a>)
|
|
</font>
|
|
</td>
|
|
<td valign=top>
|
|
<$font>
|
|
<input type="radio" name="validate-$link->{ID}" value="delete" onclick="checkValidate()" id="validate-$link->{ID}-delete">
|
|
<label for="validate-$link->{ID}-delete">Delete without reason</label>
|
|
</font>
|
|
</td>
|
|
<td valign=top>
|
|
<$font>
|
|
<input type="radio" name="validate-$link->{ID}" value="email" onclick="checkValidate()" id="validate-$link->{ID}-email">
|
|
<label for="validate-$link->{ID}-email">Delete and e-mail reason</label>
|
|
</font>
|
|
</td>
|
|
</tr>
|
|
<tr>
|
|
<td colspan=4 align="center">
|
|
<textarea name="reason-$link->{ID}" rows=5 wrap="off" cols=40>$reason</textarea>
|
|
</td>
|
|
</tr>
|
|
</table>
|
|
</td></tr>
|
|
</table>
|
|
<br>
|
|
HTML
|
|
}
|
|
my $toolbar;
|
|
if ($total > $mh) {
|
|
my $cgi = GT::CGI->new("do=page&page=tools_validate.html;nh=$nh;mh=$mh");
|
|
$toolbar = $html->toolbar($nh, $mh, $total, $cgi->url);
|
|
}
|
|
return { output => $output, results => $results, total => $total, toolbar => $toolbar };
|
|
}
|
|
|
|
sub validate_changes {
|
|
# ------------------------------------------------------------------
|
|
# Display a list of links waiting to be validated.
|
|
#
|
|
my $db = $DB->table('Links');
|
|
my $chg_db = $DB->table('Changes');
|
|
my $cat_link = $DB->table('CatLinks');
|
|
my $user_db = $DB->table('Users');
|
|
my $html = $DB->html($db, $IN);
|
|
my $font = 'font face="Tahoma,Arial,Helvetica" size="1"';
|
|
my $nh = $IN->param('nh') || 1;
|
|
my $mh = $IN->param('mh') || 5;
|
|
|
|
# Process any actions.
|
|
my $results = _validate($db);
|
|
|
|
# Get a list of links awaiting validation.
|
|
my $sth = $chg_db->query_sth({
|
|
LinkID => '*',
|
|
nh => $nh,
|
|
mh => $mh
|
|
});
|
|
my $total = $chg_db->hits;
|
|
my $i = 0;
|
|
|
|
my $output = '';
|
|
while (my $link_data = $sth->fetchrow_hashref) {
|
|
$i++;
|
|
my $link = eval $link_data->{ChgRequest};
|
|
|
|
# Old Change requests may contain ExpiryDate, which can overwrite payments made
|
|
# by the user after making a modify request. Delete it so the ExpiryDate is
|
|
# pulled from the current link data.
|
|
delete $link->{ExpiryDate};
|
|
|
|
# Only the changed column data are saved in the Changes table
|
|
my $orig = $db->get($link->{ID}) || {};
|
|
$link = { %$orig, %$link };
|
|
|
|
# Check that the ExpiryDate is valid for the categories the link is in
|
|
if ($CFG->{payment}->{enabled}) {
|
|
require Links::Payment;
|
|
my $expiry = Links::Payment::check_expiry_date($orig, $link->{'CatLinks.CategoryID'});
|
|
$link->{ExpiryDate} = $expiry if $expiry;
|
|
}
|
|
|
|
my $user = $user_db->get($link->{LinkOwner}) || {};
|
|
foreach my $col (keys %{$db->{schema}->{cols}}) {
|
|
exists $link->{$col} or $link->{$col} = $db->{schema}->{cols}->{$col}->{default};
|
|
}
|
|
$link->{$i . "-CatLinks.CategoryID"} = $link->{'CatLinks.CategoryID'};
|
|
$link->{detailed_url} = "$CFG->{build_detail_url}/" . $db->detailed_url($link->{ID});
|
|
my $form = $html->form({ values => $link, extra_table => 0, mode => 'validate', view_key => 1, multiple => $i, hide => ['Timestmp'], file_field => 1, file_delete => 1, file_use_path => 1, show_diff => 1 });
|
|
|
|
# Load reason.
|
|
my $reason = Links::send_email('link_rejected.eml', { %$user, %$link, modify => 1 }, { get_body => 1 });
|
|
|
|
my $eURL = $IN->html_escape($link->{URL});
|
|
|
|
$output .= <<HTML;
|
|
<table border=1 cellpadding=0 cellspacing=0 width=500>
|
|
<tr><td>$form</td></tr>
|
|
<tr><td>
|
|
<table border=0 cellpadding=3 cellspacing=2 width="100%">
|
|
<tr>
|
|
<td valign=top>
|
|
<$font>
|
|
<input type="radio" name="validate-$link->{ID}" value="" onclick="checkValidate()" id="validate-$link->{ID}-nothing" checked>
|
|
<label for="validate-$link->{ID}-nothing">Do nothing</label>
|
|
</font>
|
|
</td>
|
|
<td valign=top>
|
|
<$font>
|
|
<input type="radio" name="validate-$link->{ID}" value="modify" onclick="checkValidate()" id="validate-$link->{ID}-modify">
|
|
<label for="validate-$link->{ID}-modify">Modify</label>
|
|
(<a href="$eURL" target="modify">view</a>)
|
|
</font>
|
|
</td>
|
|
<td valign=top>
|
|
<$font>
|
|
<input type="radio" name="validate-$link->{ID}" value="deletechange" onclick="checkValidate()" id="validate-$link->{ID}-delete">
|
|
<label for="validate-$link->{ID}-delete">Delete without reason</label>
|
|
</font>
|
|
</td>
|
|
<td valign=top>
|
|
<$font>
|
|
<input type="radio" name="validate-$link->{ID}" value="emailchange" onclick="checkValidate()" id="validate-$link->{ID}-email">
|
|
<label for="validate-$link->{ID}-email">Delete and e-mail reason</label>
|
|
</font>
|
|
</td>
|
|
</tr>
|
|
<tr>
|
|
<td colspan=4 align="center">
|
|
<textarea name="reason-$link->{ID}" wrap="off" rows=5 cols=40>$reason</textarea>
|
|
</td>
|
|
</tr>
|
|
</table>
|
|
</td></tr>
|
|
</table>
|
|
<br>
|
|
HTML
|
|
}
|
|
my $toolbar;
|
|
if ($total > $mh) {
|
|
my $cgi = GT::CGI->new("do=page&page=tools_validate_changes.html;nh=$nh;mh=$mh");
|
|
$toolbar = $html->toolbar($nh, $mh, $total, $cgi->url);
|
|
}
|
|
return { output => $output, results => $results, total => $total, toolbar => $toolbar };
|
|
}
|
|
|
|
sub validate_reviews {
|
|
# ------------------------------------------------------------------
|
|
# Display a list of reviews waiting to be validated.
|
|
#
|
|
my $db = $DB->table('Reviews');
|
|
my $user_db = $DB->table('Users');
|
|
my $link_db = $DB->table('Links');
|
|
my $html = $DB->html( $db, $IN );
|
|
my $font = 'font face="Tahoma,Arial,Helvetica" size="1"';
|
|
my $nh = $IN->param('nh') || 1;
|
|
my $mh = $IN->param('mh') || 5;
|
|
|
|
# Process any actions.
|
|
my $results = _validate_review($db);
|
|
|
|
# Clear our cgi so we don't cause conflicts.
|
|
$html->{input} = {};
|
|
|
|
# Get a list of links awaiting validation.
|
|
my $sth = $db->query_sth({
|
|
Review_Validated => 'No',
|
|
mh => $mh,
|
|
nh => $nh,
|
|
sb => 'Review_Date',
|
|
so => 'DESC'
|
|
});
|
|
my $total = $db->hits;
|
|
my $i = 0;
|
|
|
|
my $output = '';
|
|
while (my $review = $sth->fetchrow_hashref) {
|
|
$i++;
|
|
my $form = $html->form({ values => $review, extra_table => 0, mode => 'validate', view_key => 1, multiple => $i, file_field => 1, file_delete => 1 });
|
|
|
|
# Format the date
|
|
Links::init_date();
|
|
$review->{Review_Date} = GT::Date::date_transform($review->{Review_Date}, '%yyyy%-%mm%-%dd%', $CFG->{date_user_format});
|
|
|
|
my $user = $user_db->get($review->{Review_Owner}) || {};
|
|
my $link = $link_db->get($review->{Review_LinkID}) || {};
|
|
$link->{detailed_url} = "$CFG->{build_detail_url}/" . $link_db->detailed_url($link->{ID});
|
|
|
|
# Load reason.
|
|
my $reason = Links::send_email('review_rejected.eml', { %$user, %$link, %$review }, { get_body => 1 });
|
|
|
|
$output .= <<HTML;
|
|
<table border=1 cellpadding=0 cellspacing=0 width=500>
|
|
<tr><td>$form</td></tr>
|
|
<tr><td>
|
|
<table border=0 cellpadding=3 cellspacing=2 width="100%">
|
|
<tr>
|
|
<td valign=top>
|
|
<$font>
|
|
<input type="radio" name="validate-$review->{ReviewID}" value="" onclick="checkValidate()" id="validate-$review->{ReviewID}-nothing" checked>
|
|
<label for="validate-$review->{ReviewID}-nothing">Do nothing</label>
|
|
</font>
|
|
</td>
|
|
<td valign=top>
|
|
<$font>
|
|
<input type="radio" name="validate-$review->{ReviewID}" value="validate" onclick="checkValidate()" id="validate-$review->{ReviewID}-validate">
|
|
<label for="validate-$review->{ReviewID}-validate">Validate</label>
|
|
</font>
|
|
</td>
|
|
<td valign=top>
|
|
<$font>
|
|
<input type="radio" name="validate-$review->{ReviewID}" value="delete" onclick="checkValidate()" id="validate-$review->{ReviewID}-delete">
|
|
<label for="validate-$review->{ReviewID}-delete">Delete without reason</label>
|
|
</font>
|
|
</td>
|
|
<td valign=top>
|
|
<$font>
|
|
<input type="radio" name="validate-$review->{ReviewID}" value="email" onclick="checkValidate()" id="validate-$review->{ReviewID}-email">
|
|
<label for="validate-$review->{ReviewID}-email">Delete and e-mail reason</label>
|
|
</font>
|
|
</td>
|
|
</tr>
|
|
<tr>
|
|
<td colspan=4 align="center">
|
|
<textarea name="reason-$review->{ReviewID}" rows=5 wrap="off" cols=40>$reason</textarea>
|
|
</td>
|
|
</tr>
|
|
</table>
|
|
</td></tr>
|
|
</table>
|
|
<br>
|
|
HTML
|
|
}
|
|
my $toolbar;
|
|
if ($total > $mh) {
|
|
my $cgi = GT::CGI->new("do=page&page=tools_validate_reviews.html;nh=$nh;mh=$mh");
|
|
$toolbar = $html->toolbar($nh, $mh, $total, $cgi->url);
|
|
}
|
|
return { output => $output, results => $results, total => $total, toolbar => $toolbar };
|
|
}
|
|
|
|
sub _validate_review {
|
|
# -------------------------------------------------------------------
|
|
# Validate/delete/email review.
|
|
#
|
|
my $db = shift;
|
|
|
|
# Let's parse out the form, and group our reviews together.
|
|
my $args = $IN->get_hash();
|
|
my (@validate, @email, @delete, @modify, $tmp);
|
|
while (my ($key, $param) = each %$args) {
|
|
if ($key =~ /^validate-(\d+)/) {
|
|
push @validate, $1 if $param eq 'validate';
|
|
push @email, $1 if $param eq 'email';
|
|
push @delete, $1 if $param eq 'delete';
|
|
}
|
|
elsif ($key =~ /^(\d+)-(.*)$/) {
|
|
$tmp->{$1}->{$2} = $param;
|
|
}
|
|
}
|
|
my $review = {};
|
|
foreach (keys %$tmp) {
|
|
$review->{$tmp->{$_}->{ReviewID}} = $tmp->{$_};
|
|
}
|
|
unless (@validate or @email or @delete ) {
|
|
return;
|
|
}
|
|
|
|
# Now validate everyone.
|
|
my %error;
|
|
foreach my $id (@validate) {
|
|
my $res = $PLG->dispatch('validate_review', \&_validate_review_record, $review->{$id});
|
|
if ($res) { $error{$id} = $res }
|
|
}
|
|
|
|
# Delete records.
|
|
foreach my $id (@delete) {
|
|
$db->delete({ ReviewID => $id }) or $error{$id} = "<li>$id (Couldn't delete: $GT::SQL::error)";
|
|
}
|
|
|
|
# Delete and email records.
|
|
foreach my $id (@email) {
|
|
my $res = _delete_email_review_record($review->{$id}, $IN->param("reason-$id"));
|
|
if ($res) { $error{$id} = $res }
|
|
}
|
|
|
|
my $results = join "", values %error;
|
|
return $results
|
|
? "<font color=red><ul>$results</ul></font>"
|
|
: "<font color=green>All Reviews successfully validated/deleted.</font>";
|
|
}
|
|
|
|
sub _validate_review_record {
|
|
# -------------------------------------------------------------------
|
|
# Validates a record.
|
|
#
|
|
my $review = shift;
|
|
|
|
# Update the database.
|
|
my $db = $DB->table('Reviews');
|
|
$review->{Review_Validated} = 'Yes';
|
|
|
|
$db->modify($review) or return Links::language('VAL_GENERAL', $review->{ID}, $GT::SQL::error);
|
|
|
|
# Add the link info to the fields.
|
|
my $link = $DB->table('Links')->get($review->{Review_LinkID});
|
|
$link->{detailed_url} = "$CFG->{build_detail_url}/" . $DB->table('Links')->detailed_url($link->{ID});
|
|
foreach my $key (keys %$link) {
|
|
exists $review->{$key} or $review->{$key} = $link->{$key};
|
|
}
|
|
|
|
# Add the user info to the fields.
|
|
my $user_db = $DB->table('Users');
|
|
my $user_info = $user_db->get($review->{Review_Owner});
|
|
foreach (keys %$user_info) {
|
|
$review->{$_} = $user_info->{$_} unless exists $review->{$_};
|
|
}
|
|
|
|
# Format the date
|
|
Links::init_date();
|
|
$review->{Review_Date} = GT::Date::date_transform($review->{Review_Date}, '%yyyy%-%mm%-%dd%', $CFG->{date_user_format});
|
|
|
|
# Add anonymous reviewer
|
|
$review->{anonymous} = !$CFG->{user_review_required};
|
|
|
|
if ($CFG->{email_review_add}) {
|
|
my $email = $review->{Review_GuestEmail} || $review->{Email};
|
|
unless ($email and $email =~ /^.+\@.+\..+$/) {
|
|
return Links::language('VAL_CANTEMAIL', 'No Review_GuestEmail or user Email address');
|
|
}
|
|
|
|
Links::send_email('review_added.eml', $review) or return Links::language('VAL_CANTEMAIL', $GT::Mail::error);
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub _delete_email_review_record {
|
|
# -------------------------------------------------------------------
|
|
# Delete and email a record.
|
|
#
|
|
my ($review, $reason) = @_;
|
|
my $db = $DB->table('Reviews');
|
|
my $user_db = $DB->table('Users');
|
|
|
|
# Get the email address first.
|
|
my $user_info = $user_db->get($review->{Review_Owner}) || {};
|
|
|
|
# Delete the record.
|
|
my $res = $db->delete({ ReviewID => $review->{ReviewID} });
|
|
|
|
Links::send_email('review_rejected.eml', { %$user_info, %$review }, { body => $reason }) or return Links::language('VAL_CANTEMAIL', $GT::Mail::error);
|
|
return;
|
|
}
|
|
|
|
sub _validate {
|
|
# -------------------------------------------------------------------
|
|
# Validate/delete/email and links.
|
|
#
|
|
my $db = shift;
|
|
|
|
# Let's parse out the form, and group our links together.
|
|
my $args = $IN->get_hash();
|
|
my (@validate, @email, @delete, @modify, @delete_change, @email_change, $tmp);
|
|
while (my ($key, $param) = each %$args) {
|
|
if ($key =~ /^validate-(\d+)/) {
|
|
push @validate, $1 if $param eq 'validate';
|
|
push @email, $1 if $param eq 'email';
|
|
push @delete, $1 if $param eq 'delete';
|
|
push @modify, $1 if $param eq 'modify';
|
|
push @delete_change, $1 if $param eq 'deletechange';
|
|
push @email_change, $1 if $param eq 'emailchange';
|
|
}
|
|
if ($key =~ /^(\d+)-(.*)$/) {
|
|
$tmp->{$1}->{$2} = $param;
|
|
}
|
|
}
|
|
my $links = {};
|
|
foreach (keys %$tmp) {
|
|
$links->{$tmp->{$_}->{ID}} = $tmp->{$_};
|
|
}
|
|
unless (@validate or @email or @delete or @modify or @delete_change or @email_change) {
|
|
return;
|
|
}
|
|
|
|
# Now validate everyone.
|
|
my $email_db = $DB->table('Users');
|
|
my $chng_db = $DB->table('Changes');
|
|
my %error;
|
|
foreach my $id (@validate) {
|
|
$links->{$id}->{_mode} = 'validate';
|
|
my $res = $PLG->dispatch('validate_link', \&_validate_record, $links->{$id});
|
|
$error{$id} = $res if $res;
|
|
}
|
|
|
|
# Now modify everyone.
|
|
foreach my $id (@modify) {
|
|
$links->{$id}->{_mode} = 'modify';
|
|
my $res = $PLG->dispatch('validate_link', \&_validate_record, $links->{$id});
|
|
if ($res) {
|
|
$error{$id} = $res;
|
|
}
|
|
else {
|
|
$chng_db->delete({ LinkID => $id });
|
|
}
|
|
}
|
|
|
|
# Delete records.
|
|
foreach my $id (@delete) {
|
|
my $results = $PLG->dispatch('validate_delete', \&_delete_record, $db, $id);
|
|
$results or $error{$id} = "<li>$id (Couldn't delete: $GT::SQL::error)";
|
|
}
|
|
|
|
# Delete and email records.
|
|
foreach my $id (@email) {
|
|
my $res = $PLG->dispatch('validate_delete_email', \&_delete_email_record, $db, $email_db, $links->{$id}, $IN->param("reason-$id"));
|
|
$error{$id} = $res if $res;
|
|
}
|
|
|
|
# Delete change requests
|
|
foreach my $id (@delete_change) {
|
|
my $results = $PLG->dispatch('validate_delete_change', \&_delete_change, $id);
|
|
$results or $error{$id} = "<li>$id (Couldn't delete: $GT::SQL::error)";
|
|
}
|
|
# Delete and email change requests.
|
|
foreach my $id (@email_change) {
|
|
my $res = $PLG->dispatch('validate_delete_change_email', \&_delete_email_change_record, $db, $email_db, $links->{$id}, $IN->param("reason-$id"));
|
|
$error{$id} = $res if $res;
|
|
}
|
|
|
|
my $results = join "", values %error;
|
|
return $results
|
|
? "<font color=red><ul>$results</ul></font>"
|
|
: "<font color=green>All Links successfully validated/deleted.</font>";
|
|
}
|
|
|
|
sub _validate_record {
|
|
# -------------------------------------------------------------------
|
|
# Validates a record.
|
|
#
|
|
my $link = shift;
|
|
# Update the database.
|
|
my $type = $link->{_mode};
|
|
my $db = $DB->table('Links');
|
|
delete $link->{Timestmp} if ($type eq 'modify');
|
|
$link->{isValidated} = 'Yes';
|
|
|
|
# Check the paths
|
|
my %fcols = $db->_file_cols();
|
|
for ( keys %fcols ) {
|
|
require GT::SQL::File;
|
|
my $path = $link->{$_."_path"} or next;
|
|
$path =~ m,^$CFG->{admin_root_path}/tmp, or next;
|
|
$link->{$_} = GT::SQL::File->open($path);
|
|
}
|
|
|
|
# Add back the extra time that it took the admin to validate the link.
|
|
if ($type ne 'modify' and $CFG->{payment}->{enabled} and exists $link->{ExpiryDate}) {
|
|
my $orig_expiry = $db->select(ExpiryDate => { ID => $link->{ID} })->fetchrow();
|
|
my $new_expiry = Links::date_to_time($link->{ExpiryDate}) || $link->{ExpiryDate};
|
|
|
|
# We only add the extra time if the admin hasn't changed the expiry and the
|
|
# expiry is a real date
|
|
if ($new_expiry == $orig_expiry and $orig_expiry > 0 and $orig_expiry < UNLIMITED) {
|
|
my $payments = $DB->table('Payments');
|
|
my $payment_time = $payments->select(payments_last => {
|
|
payments_linkid => $link->{ID},
|
|
payments_status => COMPLETED
|
|
})->fetchrow();
|
|
|
|
if ($payment_time) {
|
|
my $lost_time = time - $payment_time;
|
|
$link->{ExpiryDate} = $orig_expiry + $lost_time;
|
|
}
|
|
}
|
|
}
|
|
|
|
$db->modify($link) or return Links::language('VAL_GENERAL', $link->{ID}, $GT::SQL::error);
|
|
|
|
for (keys %fcols) {
|
|
$link->{"${_}_path"} =~ m|^$CFG->{admin_root_path}/tmp/|
|
|
and _file_path_ok($link->{$_."_path"})
|
|
and unlink $link->{$_."_path"};
|
|
}
|
|
|
|
# Add the user info to the fields.
|
|
my $user_db = $DB->table('Users');
|
|
my $user_info = $user_db->get($link->{LinkOwner}) || {};
|
|
for (keys %$user_info) {
|
|
$link->{$_} = $user_info->{$_} unless exists $link->{$_};
|
|
}
|
|
|
|
# Setup category tag, and Contact_Email, Contact_Name.
|
|
$link->{Category} = join "\n", values %{$db->get_categories($link->{ID})};
|
|
|
|
if (($type eq 'validate' and $CFG->{email_add}) or ($type eq 'modify' and $CFG->{email_mod})) {
|
|
my $email = $link->{Contact_Email} || $link->{Email};
|
|
unless ($email and $email =~ /^.+\@.+\..+$/) {
|
|
return Links::language('VAL_CANTEMAIL', 'No Contact_Email or user Email address');
|
|
}
|
|
|
|
$link->{detailed_url} = "$CFG->{build_detail_url}/" . $db->detailed_url($link->{ID});
|
|
|
|
Links::send_email($type eq 'validate' ? 'link_added.eml' : 'link_modified.eml', $link) or return Links::language('VAL_CANTEMAIL', $GT::Mail::error);
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub _delete_email_record {
|
|
# -------------------------------------------------------------------
|
|
# Delete and email a record.
|
|
#
|
|
my ($db, $email_db, $link, $reason) = @_;
|
|
|
|
# Get the email address first.
|
|
my $email = $email_db->get($link->{LinkOwner}, 'HASH') || {};
|
|
|
|
# Delete the record.
|
|
_delete_record($db, $link->{ID}) or return $GT::SQL::error;
|
|
|
|
$link->{Category} = join "\n", values %{$db->get_categories($link->{ID})};
|
|
Links::send_email('link_rejected.eml', { %$email, %$link }, { body => $reason }) or return Links::language('VAL_CANTEMAIL', $GT::Mail::error);
|
|
return;
|
|
}
|
|
|
|
sub _delete_email_change_record {
|
|
# -------------------------------------------------------------------
|
|
# Delete and email a change request.
|
|
#
|
|
my ($db, $email_db, $link, $reason) = @_;
|
|
|
|
# Get the email address first.
|
|
my $email = $email_db->get($link->{LinkOwner}, 'HASH') || {};
|
|
|
|
# Delete the record.
|
|
_delete_change($link->{ID}) or return $GT::SQL::error;
|
|
|
|
$link->{Category} = join "\n", values %{$db->get_categories($link->{ID})};
|
|
Links::send_email('link_rejected.eml', { %$email, %$link, modify => 1 }, { body => $reason }) or return Links::language('VAL_CANTEMAIL', $GT::Mail::error);
|
|
return;
|
|
}
|
|
|
|
sub _delete_record {
|
|
# -------------------------------------------------------------------
|
|
# Deletes a link waiting to be validated, and the user that submitted it.
|
|
#
|
|
my ($db, $id) = @_;
|
|
my $link = $db->get($id, 'HASH', ['LinkOwner']);
|
|
$db->delete({ ID => $id }) or return Links::language('VAL_GENERAL', $id, $GT::SQL::error);
|
|
|
|
# Remove the user if that's their only record and they were auto-setup.
|
|
if ($link) {
|
|
my $records = $db->count({ LinkOwner => $link->{LinkOwner}, Status => 'Not Validated' });
|
|
if (!$records) {
|
|
my $user_db = $DB->table('Users');
|
|
$user_db->delete({ Username => $link->{LinkOwner}, Status => 'Not Validated' });
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub _delete_change {
|
|
# -------------------------------------------------------------------
|
|
# Deletes a link waiting to be validated, and the user that submitted it.
|
|
#
|
|
my $id = shift;
|
|
my $db = $DB->table('Changes');
|
|
my %fcols = $DB->table('Links')->_file_cols();
|
|
my $href = $db->get({ LinkID => $id }) || {};
|
|
$href = eval $href->{ChgRequest};
|
|
|
|
for (keys %fcols) {
|
|
my $fpath = $href->{$_};
|
|
$fpath =~ m,^$CFG->{admin_root_path}/tmp/, and _file_path_ok($fpath) and unlink $fpath;
|
|
}
|
|
$db->delete({ LinkID => $id });
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub _file_path_ok {
|
|
# -------------------------------------------------------------------
|
|
my $fpath = shift;
|
|
return $fpath !~ /\.\./
|
|
and $fpath =~ /^[\w\\\/\-\.%]+$/
|
|
and -e $fpath
|
|
and $fpath =~ m|^$CFG->{admin_root_path}/tmp/|;
|
|
}
|
|
|
|
sub quick_links {
|
|
# -------------------------------------------------------------------
|
|
# Add quick links to the admin menu.
|
|
#
|
|
my $name = $IN->param('name');
|
|
my $url = $IN->param('url');
|
|
my $manage = $IN->param('manage') || '';
|
|
my @to_delete = $IN->param('remove');
|
|
if ($IN->param('delete')) {
|
|
foreach my $url (@to_delete) {
|
|
delete $CFG->{quick_links}->{$url};
|
|
}
|
|
$CFG->save;
|
|
}
|
|
|
|
if ($name and $url) {
|
|
$CFG->{quick_links}->{$url} = $name;
|
|
$CFG->save;
|
|
}
|
|
my $output;
|
|
foreach my $url (sort { $CFG->{quick_links}->{$a} cmp $CFG->{quick_links}->{$b} } keys %{$CFG->{quick_links}}) {
|
|
$output .= qq~<input type="checkbox" name="remove" value="$url"> ~ if $manage;
|
|
$output .= qq~ <a href="$url">$CFG->{quick_links}->{$url}</a><br>~;
|
|
}
|
|
return { quick_links => $output }
|
|
}
|
|
|
|
sub sql_monitor {
|
|
# -------------------------------------------------------------------
|
|
# Runs queries.
|
|
#
|
|
my $query = $IN->param('query');
|
|
my $file = $IN->param('saveto');
|
|
my $style = $IN->param('style');
|
|
my $table = $DB->table('Links');
|
|
|
|
if ($query) {
|
|
require GT::SQL::Monitor;
|
|
my $ran = GT::SQL::Monitor::query(
|
|
table => $table,
|
|
style => $style || 'tabs',
|
|
query => $query,
|
|
html => !$file
|
|
);
|
|
|
|
return $ran if $ran->{error};
|
|
|
|
if ($file) {
|
|
return { %$ran, error => 1, error_other => "The file '$file' already exists." } if -e $file;
|
|
local *FILE;
|
|
open FILE, "> $file" or return { %$ran, error => 1, error_other => "Unable to open file '$file': $!" };
|
|
print FILE ${delete $ran->{results}};
|
|
$ran->{results} = \"Results written to '$file'";
|
|
}
|
|
return $ran;
|
|
}
|
|
|
|
return {
|
|
db_prefix => $DB->prefix,
|
|
style => $style,
|
|
saveto => $file
|
|
};
|
|
}
|
|
|
|
sub remote_user {
|
|
# -------------------------------------------------------------------
|
|
# Returns a remote_user environment variable.
|
|
#
|
|
my $user = $ENV{REMOTE_USER} or return '';
|
|
$user eq '-' and return ''; # xitami sets it to '-', ugh.
|
|
return $user;
|
|
}
|
|
|
|
sub auth_users {
|
|
# -----------------------------------------------------------------------------
|
|
# Returns a htpasswd_users template loop variable of users in the .htpasswd
|
|
# file, and htpasswd_users_count of the number of users.
|
|
#
|
|
my $htpasswd = "$CFG->{admin_root_path}/.htpasswd";
|
|
|
|
local *HTPAS;
|
|
open HTPAS, "< $htpasswd" or die "Could not open '$htpasswd': $!";
|
|
my @users = map { /^([^:]+):/ ? $1 : () } <HTPAS>;
|
|
close HTPAS;
|
|
|
|
return {
|
|
htpasswd_users_count => scalar @users,
|
|
htpasswd_users => \@users
|
|
};
|
|
}
|
|
|
|
sub category_list {
|
|
# -------------------------------------------------------------------
|
|
# Return a list of categories. If db_gen_category_list is 1 (basic, not
|
|
# treecats), then an array of all categories will be returned. If
|
|
# db_gen_category_list is 0, then only an array of the selected categories will
|
|
# be returned.
|
|
#
|
|
my %ret;
|
|
my @ids = $IN->param('CatLinks.CategoryID');
|
|
@ids = $IN->param('ID') unless @ids;
|
|
|
|
my $cat = $DB->table('Category');
|
|
$cat->select_options('ORDER BY Full_Name');
|
|
|
|
if ($CFG->{db_gen_category_list} == 1) {
|
|
my $sth = $cat->select();
|
|
my @cats;
|
|
while (my $c = $sth->fetchrow_hashref) {
|
|
for (0 .. $#ids) {
|
|
if ($c->{ID} == $ids[$_]) {
|
|
$c->{selected} = 1;
|
|
splice @ids, $_, 1;
|
|
last;
|
|
}
|
|
}
|
|
push @cats, $c;
|
|
}
|
|
$ret{category_loop} = \@cats;
|
|
$ret{category_loop_selected} = 0;
|
|
}
|
|
elsif ($CFG->{db_gen_category_list} == 0) {
|
|
$ret{category_loop} = @ids ? $cat->select({ ID => \@ids })->fetchall_hashref : [];
|
|
$ret{category_loop_selected} = 1;
|
|
}
|
|
return \%ret;
|
|
}
|
|
|
|
sub category_list_html {
|
|
# -------------------------------------------------------------------
|
|
# Return the html for a list of all the categories. Deprecated, use
|
|
# the above category_list instead!
|
|
#
|
|
my $category;
|
|
if ($CFG->{db_gen_category_list}) {
|
|
my $links = $DB->table('Links');
|
|
my $html = $DB->html($links, $IN);
|
|
my @ids = $IN->param('CatLinks.CategoryID');
|
|
@ids = $IN->param('ID') unless @ids;
|
|
$category = $html->get_all_categories(\@ids, 'CatLinks.CategoryID', 1);
|
|
}
|
|
else {
|
|
my $id = $IN->param('CatLinks.CategoryID') || $IN->param('ID');
|
|
my $name = $DB->table('Category')->select('Full_Name', { ID => $id })->fetchrow;
|
|
if ($name) {
|
|
$category = qq|$name <input type="hidden" name="CatLinks.CategoryID" value="$id">|;
|
|
}
|
|
else {
|
|
return;
|
|
}
|
|
}
|
|
return $category;
|
|
}
|
|
|
|
sub category_list_selected {
|
|
# -------------------------------------------------------------------
|
|
# Return a list of all the selected categories. Looping through a long list of
|
|
# categories in GT::Template can be slow, especially if you only need the
|
|
# selected ones.
|
|
#
|
|
my @ids = $IN->param('CatLinks.CategoryID');
|
|
@ids = $IN->param('ID') unless @ids;
|
|
return unless @ids;
|
|
my $cat = $DB->table('Category');
|
|
$cat->select_options("ORDER BY Full_Name");
|
|
return $cat->select({ ID => \@ids })->fetchall_hashref;
|
|
}
|
|
|
|
1;
|