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~
$eurl - $count
~;
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~
~;
}
}
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 = "
Code
Description
Delete
";
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~
$code
~;
}
$table .= qq~
New:
~;
my $prefix_output;
foreach my $prefix (sort keys %prefix_list) {
$prefix_output .= qq~
$prefix ($prefix_list{$prefix}) |~;
}
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 = "
Code
Description
Delete
";
for my $code (sort keys %$globals) {
my $str = $IN->html_escape($globals->{$code});
$table .= qq~
$code
~;
}
$table .= qq~
New:
~;
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 = ;
}
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'";
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)}{$1}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
}
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
}
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 .= <
$form
<$font>
<$font>
<$font>
<$font>
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} = "
$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
? "
$results
"
: "All Reviews successfully validated/deleted.";
}
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} = "
$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} = "
$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
? "
$results
"
: "All Links successfully validated/deleted.";
}
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~ ~ if $manage;
$output .= qq~ $CFG->{quick_links}->{$url} ~;
}
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 : () } ;
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 |;
}
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;