# ==================================================================
# 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>&nbsp;</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>&nbsp;</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~&nbsp; <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;
