# ==================================================================
# 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: Links.pm,v 1.227 2009/05/09 17:01:33 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;
# ==================================================================
use strict;
use vars qw/
    $VERSION $DEBUG
    $IN $DB $CFG $USER
    $PLG $GLOBALS $TPL $LANGUAGE
    %STASH
    @EXPORT_OK %EXPORT_TAGS @ISA
/;

# Load Links::Custom before anything else.  Usually, it is empty, but it is not
# overwritten during upgrades, and so site-specific options (for example, a
# "use lib" required to make your installation work) can go in there.
use Links::Custom;

use GT::Base qw/:all/;
use Exporter();
use GT::AutoLoader;

use GT::Config;
use GT::CGI;
use GT::Template;
use GT::Plugins;
use GT::Delay;
use GT::Date;
use Links::Config;

use constants
    # Payment option constants
    GLOBAL       => 0,
    NOT_ACCEPTED => 1,
    OPTIONAL     => 2,
    REQUIRED     => 3,

    # Payment expiry special values (anything else is a unix time)
    UNPAID       => -1,
    UNLIMITED    => 0x7fff_fffe,
    FREE         => 0x7fff_ffff;

$DEBUG   = 0;
$VERSION = '3.3.0';

@ISA = 'Exporter';
# $TPL is still exported for compatibility with (very) old plugins
@EXPORT_OK = qw(
    $IN $CFG $DB $USER $PLG $TPL %STASH $MOD_PERL MOD_PERL SPEEDY PERSIST
    GLOBAL NOT_ACCEPTED OPTIONAL REQUIRED UNPAID FREE UNLIMITED
    VIEWABLE
);

%EXPORT_TAGS = (
    'payment' => [qw/GLOBAL NOT_ACCEPTED OPTIONAL REQUIRED UNPAID FREE UNLIMITED/],
    'objects' => [qw/$IN $CFG $DB $USER $PLG %STASH VIEWABLE/],
    'persist' => [qw/MOD_PERL SPEEDY PERSIST/]
);

# Returns a new condition object to use for viewable links.  Currently, this
# means isValidated = 'Yes', and, if payment support is enabled,
# ExpiryDate >= time.  You can use it as:
# my $cond = VIEWABLE; $cond->add(some => other => condition);
# or:
# $table->select(VIEWABLE);
# or:
# $table->select({ column => $value }, VIEWABLE);
sub VIEWABLE() {
    require GT::SQL::Condition;
    my $cond = GT::SQL::Condition->new(isValidated => '=' => 'Yes');
    $cond->add(ExpiryDate => '>=' => time) if $CFG->{payment}->{enabled};
    $cond;
}

sub init {
# --------------------------------------------------------------------
# This function initializes Gossamer Links, and must be called before any other
# action is performed.
#
    my $path = shift || '.';

# If under mod_perl, reset our environments.
    if (PERSIST) {
        GT::SQL->reset_env if $INC{'GT/SQL.pm'};
        GT::CGI->reset_env();
    }

# Get our config object.
    $CFG = Links::Config->new($path);
    my $debug = $CFG->{debug_level} || $DEBUG;

# Set our tmp directory to store files.
    $ENV{GT_TMPDIR} = $CFG->{admin_root_path} . '/tmp';
    $IN = GT::CGI->new();
    $PLG = GT::Plugins->new(directory => "$CFG->{admin_root_path}/Plugins", debug => $debug);

    if ($DB and not ref $DB eq 'GT::Delay') { # $DB is already a GT::SQL object
        $DB = GT::SQL->new({
            def_path => $CFG->{admin_root_path} . '/defs',
            cache => 1,
            debug => $debug,
        });
    }
    else {
        $DB = GT::Delay(
            'GT::SQL', 'HASH',
            {
                def_path => $CFG->{admin_root_path} . '/defs',
                cache => 1,
                debug => $debug,
            }
        );
    }

    $PLG->dispatch('init', sub {});

    (%STASH, $GLOBALS, $LANGUAGE, $USER) = ();
}

sub init_date {
# --------------------------------------------------------------------
# Load the date module and setup any custom date strings.
#
    return unless $CFG and not $STASH{date_loaded};

    my $debug = defined $CFG->{debug_level} ? $CFG->{debug_level} : $DEBUG;

    require GT::Date;
    $GT::Date::DEBUG      = $debug if ($debug);
    $GT::Date::OFFSET     = $CFG->{date_offset} * 3600;
    $GT::Date::LANGUAGE   = {
        'month_names'       => $CFG->{date_month_long},
        'day_names'         => $CFG->{date_days_long},
        'short_month_names' => $CFG->{date_month_short},
        'short_day_names'   => $CFG->{date_days_short}
    };
    GT::Date::build_lang();
    $STASH{date_loaded} = 1;
}

sub init_user {
# --------------------------------------------------------------------
# User initialization, but passes through plugins.
#
    $PLG->dispatch('init_user', sub { _plg_init_user(@_); }, @_);
}

sub _plg_init_user {
# --------------------------------------------------------------------
# Check to see if the request is for a valid user, if so, set
# $USER to the user.
#
    GT::Template->root("$CFG->{admin_root_path}/templates/" . template_set());

# Authenticate the user.
    require Links::Authenticate;
    Links::Authenticate::auth('init');

    $USER = undef;

    my $username = shift || $IN->param('Username') || undef;
    my $password = shift || $IN->param('Password') || undef;

# Validate the username, either through logging on, or checking the
# session.
    my $valid_user;
    if (defined $username && defined $password) {
        if (Links::Authenticate::auth('valid_user', { Username => $username, Password => $password })) {
            $valid_user = $username;
        }
    }
    else {
        $valid_user = Links::Authenticate::auth('valid_session');
    }
    return unless $valid_user;

# We have a valid_user, now let's get the user from Gossamer Links, if he's not there
# then we auto-create him.
    $USER = Links::Authenticate::auth('get_user', { Username => $valid_user, Password => $password, auto_create => 1 });
    if ($USER and $USER->{Status} eq 'Not Validated') {
        return;
    }
    return $USER;
}

sub init_admin {
# -----------------------------------------------------------------------------
    $PLG->dispatch('init_admin', sub { _plg_init_admin(@_); }, @_);
}

sub _plg_init_admin {
# -----------------------------------------------------------------------------
    $LANGUAGE = GT::Config->load("$CFG->{admin_root_path}/templates/admin/language.txt", { inheritance => 1, local => 1 });
}

sub check_request {
# --------------------------------------------------------------------
# Checks to make sure the request is allowed.
#
    if ($CFG->{disabled}) {
        print $IN->header;
        print Links::SiteHTML::display('error', { error => Links::language('GENERAL_DISABLED') });
        return;
    }
    if (ref $CFG->{bans}) {
        for (@{$CFG->{bans}}) {
            # Turn a ban into a regexp
            my $ban = quotemeta;
            # *'s match anything
            $ban =~ s/\\\*/.*/g;
            # +'s match anything with at least one character
            $ban =~ s/\\\+/.+/g;
            # ?'s match any single character
            $ban =~ s/\\\?/./g;
            if ($ENV{REMOTE_HOST} and $ENV{REMOTE_HOST} =~ /^$ban$/i or $ENV{REMOTE_ADDR} =~ /^$ban$/i) {
                print $IN->header;
                print Links::SiteHTML::display('error', { error => Links::language('GENERAL_BANNED') });
                return;
            }
        }
    }
    return 1;
}

sub language {
# --------------------------------------------------------------------
# Process a language request, it's only loaded once, and saved in 
# $LANGUAGE.  All arguments are automatically html escaped unless the argument
# is passed as a scalar ref.
#
    $_[0] and $_[0] eq 'Links' and shift;
    my $code = shift || '';

    $LANGUAGE ||= GT::Config->load("$CFG->{admin_root_path}/templates/" . template_set() . "/language.txt", { inheritance => 1, local => 1 });
    if (exists $LANGUAGE->{$code}) {
        return @_ ? sprintf($LANGUAGE->{$code}, map { ref $_ ? $$_ : $IN->html_escape($_) } @_) : $LANGUAGE->{$code};
    }
    else {
        return if ($code =~ /^PAYMENT_/);
        return $code;
    }
}

sub https {
# -----------------------------------------------------------------------------
# Returns 1 if the request is (probably) under HTTPS.  Under CGI or front-end
# mod_perl servers this is easy - just check for $ENV{HTTPS} eq 'on'. Under
# proxied back-end mod_perl servers it is _IMPOSSIBLE_.
#
    return ($ENV{HTTPS} and $ENV{HTTPS} eq 'on');
}

sub config_vars {
# --------------------------------------------------------------------
# Return the config as a hash for use in templates. We flatten array refs
# and hash refs.
#
    my $t = {};
    while (my ($key, $val) = each %$CFG) {
        (ref $val eq 'ARRAY') and ($val = join ",", @$val);
        (ref $val eq 'HASH')  and do { my $tmp; foreach (sort keys %$val) { $tmp .= "$_ = $val->{$_}, "; } chop $tmp; chop $tmp; $val = $tmp; };
        $t->{"cfg_$key"} = $val;
    }
    return $t;
}

$COMPILE{admin_page} = __LINE__ . <<'END_OF_SUB';
sub admin_page {
# ------------------------------------------------------------------
# Display an admin template page.
#
    (defined $_[0] and $_[0] eq 'Links') and shift;
    my ($file, $params, $opts) = @_;

    $file ||= $IN->param('page');
    $file =~ /\.\./ and return die "Invalid template '$file' requested (Invalid name)";
    $file =~ m,^/,  and return die "Invalid template '$file' requested (Invalid name)";

# Add on $IN
    $params ||= [];
    my $cgi = $IN->get_hash;
    for (keys %$cgi) {
        $cgi->{$_} = ref $cgi->{$_} eq 'ARRAY' ? join("\n", @{$cgi->{$_}}) : $cgi->{$_};
    }
    ref $params eq 'ARRAY' ? (push @$params, $cgi) : ($params = [$cgi, $params]);

    push @$params, { config => $CFG, in => $IN };

# Make sure a root is set.
    $opts ||= {};
    $opts->{root} ||= "$CFG->{admin_root_path}/templates/admin";
    defined $opts->{print} or ($opts->{print} = 1);
    defined $opts->{inheritance} or ($opts->{inheritance} = 1);
    $opts->{stream} = 1 if not exists $opts->{stream} and $IN->param('stream');

    my $cookies = [];
    if ($IN->param('set-cookie')) {
        foreach my $key ($IN->param) {
            if ($key =~ /^cookie-(.*)/) {
                my $path = $IN->param("cookie_path-$1") || '/';
                my $exp  = $IN->param("cookie_exp-$1")  || '+5y';
                push @$cookies, $IN->cookie(-name => $1, -value => $IN->param($key), -path => $path, -expires => $exp);
            }
        }
    }
    if ($opts->{print}) {
        @$cookies ? print $IN->header(-cookie => $cookies, -charset => $CFG->{header_charset}) : print $IN->header(-charset => $CFG->{header_charset});
    }

# Print the page.
    GT::Template->parse($file, $params, $opts);
}
END_OF_SUB

sub template_set {
# -----------------------------------------------------------------------------
# Tries to find and return a valid user template set name as well as a template
# theme name.  It will check input from the following in the listed order:
#     1) The first argument to template_set()
#     2) CGI input ($IN->param('t'))
#     3) $CFG->{build_default_tpl}
# If no valid template is found, then it fatals.  If no valid theme exists then
# no theme value is returned.
# 
    shift if @_ and UNIVERSAL::isa($_[0], 'Links');
    my $template_set = shift;

    for ($template_set, $IN->param('t'), $CFG->{build_default_tpl}, 'luna') {
        next unless $_;
# Template name + theme can be passed in as: <template set name>.<template theme name>
        my ($ts, $theme) = split(/\./, $_, 2);
        if (not $ts or $ts eq 'admin' or $ts eq 'browser' or $ts eq 'help' or $ts eq 'CVS' or
            $ts !~ /^[\w-]+$/o or not -d "$CFG->{admin_root_path}/templates/$ts") {
            next;
        }

        return $ts if not wantarray;

# Check to see if a valid theme was passed in with the name
        if ($theme and not theme_exists($ts, $theme)) {
            $theme = '';
        }
        if (not $theme) {
# Get a default theme name from the template set's .tplinfo
            my $tplinfo = GT::Template->load_tplinfo("$CFG->{admin_root_path}/templates/$ts");
            if ($tplinfo and $tplinfo->{default_theme} and theme_exists($ts, $tplinfo->{default_theme})) {
                $theme = $tplinfo->{default_theme};
            }
        }
        if (not $theme and theme_exists($ts, $ts)) {
# Last resort is to just take the template set name as the theme name
            $theme = $ts;
        }

        my $full = $ts;
        $full .= ".$theme" if $theme and $theme ne $ts;
        return ($ts, $theme, $full);
    }

    die "Could not find a valid template set!";
}

sub template_exists {
# -----------------------------------------------------------------------------
# Returns true/false value indicating whether the given template exists in the
# given template set, honouring inheritance.
# Example usage: template_exists('default', 'home.html');
#
    shift if @_ > 2 and $_[0] and UNIVERSAL::isa($_[0], 'Links');
    require GT::Template::Inheritance;
    my ($template_set, $filename) = @_;
    my $found = GT::Template::Inheritance->get_path(
        file            => $filename,
        path            => "$CFG->{admin_root_path}/templates/$template_set",
        use_local       => 1,
        use_inheritance => 1
    );

    return $found ? 1 : undef;
}

sub theme_exists {
# -----------------------------------------------------------------------------
# Returns true/false value indicating whether the given template them exists in
# the given template set (the template set must exist).
# Example usage: template_theme_exists('luna', 'mytheme');
#
    shift if @_ > 2 and $_[0] and UNIVERSAL::isa($_[0], 'Links');
    my ($template, $theme) = @_;

    return if $theme =~ /_core$/;
    return -e "$CFG->{build_static_path}/$template/$theme.css";
}

sub user_page {
# ------------------------------------------------------------------
# Load a user template and return it.
#
    (defined $_[0] and $_[0] eq 'Links') and shift;
    my ($file, $vars, $opts) = @_;

# Replace $vars with hash if it is a CGI object.
    $vars = $vars->get_hash if UNIVERSAL::isa($vars, 'GT::CGI');

# Figure out what template set we will use.
    my ($template_set, $theme) = template_set(delete $opts->{template});

    unless ((ref $opts and exists $opts->{string}) or ($file =~ /^[\w\-]+\.\w+$/)) {
        die "Invalid template name: $file";
    }

# Load our global variables.
    $GLOBALS = GT::Config->load("$CFG->{admin_root_path}/templates/$template_set/globals.txt", { inheritance => 1, compile_subs => 'Links', local => 1 });

# Add in selected config options.
    for (qw/db_cgi_url build_root_url build_images_url build_new_url build_ratings_url build_cool_url/) {
        $vars->{$_} ||= $CFG->{$_};
    }

# Variables we use that we don't want $IN to override if they don't exist
# (prevent XSS vulnerabilities)
    for (@{$CFG->{protected_vars}}) {
        $vars->{$_} = '' unless exists $vars->{$_};
    }

# Set up config.*, in.*, user.* template tags:
    $vars->{config} = $CFG;
    $vars->{in} = $IN;
    $vars->{user} = $USER;

# Whether or not the site is being built using nph-build.cgi
    $vars->{building_static} = $STASH{building_static} ? 1 : 0;

# Make 't' and 'theme' always available for the currently-used template set:
    $vars->{t} = $template_set;
    $vars->{theme} = $theme;

# Set a page_id so users can do <%if page_id eq 'home'%>
    ($vars->{page_id} = $file) =~ s/\..{3,4}$//;

# This is used all over the place in the templates, so generate it here instead
# of in template code, since it's cleaner to do it here
    $vars->{home_index} = $CFG->{build_home} || ($CFG->{build_index_include} ? $CFG->{build_index} : '');

# If db_cgi_url_https is empty, figure it out from db_cgi_url
    my $https_url = $CFG->{db_cgi_url_https};
    unless ($https_url and $https_url =~ /\S/) {
        ($https_url = $CFG->{db_cgi_url}) =~ s|^(?:\w+://)?|https://|;
    }
    $vars->{db_cgi_url_https} = $https_url;

# Return a query string
    my $in_hash = $IN->get_hash(0);
    my @url_hidden;
    foreach (@{$CFG->{dynamic_preserve}}) {
        next unless defined $in_hash->{$_} and $in_hash->{$_} =~ /\S/;
        push @url_hidden, $IN->escape($_) . "=" . $IN->escape($in_hash->{$_});
        $vars->{form_hidden} .= qq|<input type="hidden" name="| . $IN->escape($_) . qq|" value="| . $IN->escape($in_hash->{$_}) . qq|" />|;
    }
    $vars->{url_hidden} = join ';', @url_hidden;

# Parse and return the template, turn off compression for .txt templates.
    my $dynamic = delete $opts->{dynamic};
    $opts ||= {};
    $opts->{root}      ||= "$CFG->{admin_root_path}/templates/$template_set";
    $opts->{compress}    = $CFG->{compress} unless defined $opts->{compress};
    $opts->{print}     ||= 0;
    $opts->{inheritance} = 1 unless defined $opts->{inheritance};
    my $output = GT::Template->parse($file, [$IN, $GLOBALS, $USER || (), $vars], $opts);
    if ($dynamic and !$opts->{print} and $IN->param('d')) {
        $PLG->dispatch('clean_output', \&clean_output, \$output, $vars->{page_id});
    }
    return $output;
}

$COMPILE{send_email} = __LINE__ . <<'END_OF_SUB';
sub send_email {
# ------------------------------------------------------------------
# Send an email generated from a template.
# send_email takes 3 arguments: <template_name>, <tags>, <options>
# The available options are:
#     admin_email
#         The email should be sent as an admin email, that is, the template
#         is pulled from the admin template set directory and some of the
#         available template variables are different (see code below).
#     body
#         Replace the body of the email with the contents of this option.
#     get_body
#         Parse the email and return the body of the email (does not
#         send the email).
#
# Note that send_email uses user_page for parsing non admin emails.  This can
# be a problem because user_page adds $USER to the template's variables, which
# may be not the correct user if you're sending emails in places like the
# browser code (ie. $USER is the editor, rather than the user the email is being
# sent to).
#
# WARNING: this function does NOT do any input validation.  Your code should do
# the proper input validation on the e-mail addresses, subject and any other
# data that you put into the headers.  In particular e-mail addresses should be
# valid addresses, but more importantly, these headers should NOT contain
# newlines in them.  This would allow users to add in their own headers to the
# e-mail (eg. allow them to spam using your script).
#
    (defined $_[0] and $_[0] eq 'Links') and shift;
    my ($template, $vars, $opts) = @_;
    $vars ||= {};
    $opts ||= {};

    $vars->{db_admin_email} ||= $CFG->{db_admin_email};

    my $parsed;
    if ($opts->{admin_email}) {
        my $cfg = Links::Config::load_vars();
        $vars->{Host}    ||= $ENV{REMOTE_HOST} ? "$ENV{REMOTE_HOST} ($ENV{REMOTE_ADDR})" : $ENV{REMOTE_ADDR} ? $ENV{REMOTE_ADDR} : 'none';
        $vars->{Referer} ||= $ENV{HTTP_REFERER} ? $ENV{HTTP_REFERER} : 'none';
        my $globals = GT::Config->load("$CFG->{admin_root_path}/templates/admin/globals.txt", { inheritance => 1, compile_subs => 'Links', local => 1, create_ok => 1 });
        $parsed = GT::Template->parse($template, { %$globals, %$vars, %$cfg, config => $CFG, in => $IN }, { compress => 0, root => "$CFG->{admin_root_path}/templates/admin" });
    }
    else {
        $parsed = user_page($template, $vars, { compress => 0 });
    }
    return unless $parsed;

    require GT::Mail;
    require GT::Mail::Parse;
    my $top = GT::Mail::Parse->new(
        debug          => $CFG->{debug_level},
        in_string      => $parsed,
        crlf           => "\n",
        headers_intact => 0,
    )->parse();

# Replace the body with the body that was passed in
    if ($opts->{body}) {
        $top->body_data($opts->{body});
    }

    return $top->body_data() if $opts->{get_body};

    my $charset = $top->delete('GT-Header-Charset');
    $top->{header_charset} = $charset if $charset;

    my $mail = new GT::Mail;
    $mail->top_part($top);

    my %send_opts;
    if ($CFG->{db_smtp_server}) {
        my ($host, $port) = $CFG->{db_smtp_server} =~ /^([\w.-]+)(?::(\d+))?$/;
        %send_opts = (
            smtp          => $host,
            smtp_port     => $port,
            smtp_ssl      => $CFG->{db_smtp_ssl} || '',
            smtp_user     => $CFG->{db_smtp_user} || '',
            smtp_pass     => $CFG->{db_smtp_pass} || '',
            pbs_host      => $CFG->{db_smtp_pbs_host} || '',
            pbs_port      => $CFG->{db_smtp_pbs_port} || '',
            pbs_user      => $CFG->{db_smtp_pbs_user} || '',
            pbs_pass      => $CFG->{db_smtp_pbs_pass} || '',
            pbs_ssl       => $CFG->{db_smtp_pbs_ssl} || '',
            pbs_auth_mode => $CFG->{db_smtp_pbs_auth_mode} || ''
        );
    }
    else {
        my ($path, $args) = split(' ', $CFG->{db_mail_path}, 2);
        $send_opts{sendmail} = $path;
        $send_opts{flags} = $args if $args;
    }
    $send_opts{debug} = $CFG->{debug_level};

    $mail->top_part->delete('Date');
    $mail->send(%send_opts);
}
END_OF_SUB

sub clean_output {
# --------------------------------------------------------
# Cleans up the output for any dynamically generated pages, makes sure all
# the links go through the page.cgi script.
#
    my ($output_ref, $page_id) = @_;

# Quit if we are not using dynamic pages.
    return unless $CFG->{dynamic_pages};

    my $query = '';
    my $form = '';
    my $in = $IN->get_hash(0); # Don't concat multiple values.

# Build a query string.
    foreach (@{$CFG->{dynamic_preserve}}) {
        next if not defined $in->{$_} or $in->{$_} =~ /^\s*$/;
        $query .= $IN->escape($_) . '=' . $IN->escape($in->{$_}) . ';';
        $form .= qq|<input type="hidden" name="| . $IN->html_escape($_) . qq|" value="| . $IN->html_escape($in->{$_}) . qq|" />|;
    }
    chop $query;

# Fix up the CGI references.
    $$output_ref =~ s{(<(?:a[^>]+href|i?frame[^>]+src)\s*=\s*["']*)(\Q$CFG->{db_cgi_url}\E/[^"'>]+\.(?:cgi|pl)\??[^"'>]*)}{
        my ($begin, $url) = ($1, $2);
        $begin .= $PLG->dispatch('transform_url', \&transform_url, $url, $query, undef, $page_id);
    }eig;

# Fix up any HTML forms, and insert hidden tags.
    $$output_ref =~ s!(<form[^>]+>)!$1$form!ig;

# Build a list of urls that shouldn't be transformed (default includes
# build_static_url).  This allows users to still put other files/directories in
# the build_root_url, but not have them their urls transformed to go through
# page.cgi
    my @no_transform = @{$CFG->{dynamic_no_url_transform}};
    for (@no_transform) {
        $_ =~ s/<%(.*?)%>/if (exists $CFG->{$1}) { $CFG->{$1} } else { "<%$1%>" }/eg;
    }

# Fix up the HTML references
    $$output_ref =~ s{(<(?:a[^>]+href|i?frame[^>]+src)\s*=\s*["']*)(\Q$CFG->{build_root_url}\E/?[^"'>]*)}{
        my ($begin, $url) = ($1, $2);
        my $transform = 1;
        for (@no_transform) {
            if ($url =~ m/^\Q$_\E.+/) {
                $begin .= $url;
                $transform = 0;
                last;
            }
        }
        if ($transform) {
            $begin .= $PLG->dispatch('transform_url', \&transform_url, $url, $query, undef, $page_id);
        }
        $begin;
    }eig;
}

sub transform_url {
# --------------------------------------------------------------
# Tranform static urls into dynamic ones if dynamic mode is enabled.
# You'll want to pass in a separator (eg. &) if you're using the url in a meta
# refresh since you can't use ; in the url.
#
    my ($url, $query, $separator, $page_id) = @_;

    return $url unless $IN->param('d');

    ($url, my $anchor) = split(/#/, $url, 2);

    my $in = $IN->get_hash(0);
    unless ($query) {
        foreach (@{$CFG->{dynamic_preserve}}) {
            next if not defined $in->{$_} or $in->{$_} =~ /^\s*$/;
            $query .= $IN->escape($_) . '=' . $IN->escape($in->{$_}) . ';';
        }
        chop $query;
    }

    if ($url =~ m%^\Q$CFG->{db_cgi_url}\E/(.+\.(?:cgi|pl))\??(.*)%) {
        my ($script, $qs) = ($1, $2);
        if ($query and $qs) {
            $url = "$CFG->{db_cgi_url}/$script?$qs";
            foreach (@{$CFG->{dynamic_preserve}}) {
                next if not defined $in->{$_} or $in->{$_} =~ /^\s*$/;
                unless ($qs =~ /(?:\A|[&;])$_=/) {
                    $url .= ';' . $IN->escape($_) . '=' . $IN->escape($in->{$_});
                }
            }
        }
        else {
            $url = "$CFG->{db_cgi_url}/$script" . ($query ? "?$query" : '');
        }
    }
    elsif ($url =~ m%^\Q$CFG->{build_root_url}\E/?(.*)%) {
        my $obj = $1;
        if ($obj =~ /\.(?:jpeg|jp[eg]|gif|png|mng|js|css|cgi|pl)$/) {
            $url = "$CFG->{build_root_url}/$obj";
        }
        else {
            $url = "$CFG->{db_cgi_url}/page.cgi?g=" . $IN->escape($obj) . ($query ? ";$query" : '');
# Preserve link/category sort order as well as link column filtering
            my $pages_re = join('|', @{$CFG->{dynamic_preserve_sort_pages}});
            if ($page_id =~ /^(?:$pages_re)$/) {
                my ($new_match)  = $CFG->{build_new_url}     =~ m{^\Q$CFG->{build_root_url}\E/(.+)};
                my ($cool_match) = $CFG->{build_cool_url}    =~ m{^\Q$CFG->{build_root_url}\E/(.+)};
                my ($rate_match) = $CFG->{build_ratings_url} =~ m{^\Q$CFG->{build_root_url}\E/(.+)};
                if ($obj !~ /^(?:\Q$new_match\E|\Q$cool_match\E|\Q$rate_match\E)\/$/) {
                    for (qw/sb so cat_sb cat_so/, keys %{$DB->table('Links')->cols}) {
                        if ($IN->param($_)) {
                            $url .= ';' . $IN->escape($_) . '=' . $IN->escape($IN->param($_));
                        }
                    }
                }
            }
        }
    }

    if ($separator) {
        $url =~ s/[&;]/$separator/g;
    }

    $url .= "#$anchor" if $anchor;
    return $url;
}

sub redirect_login_url {
# --------------------------------------------------------------
# Redirects a user to the login screen, through a plugin.
#
    my $from = shift;
    $PLG->dispatch('auth_redirect_login', \&_redirect_login_url, $from);
}

sub _redirect_login_url {
# --------------------------------------------------------------
# Redirect the user to the login screen.
#
    my ($from) = shift;
    my $url = $IN->url(query_string => 1);
    $url = $IN->escape($CFG->{db_cgi_url} . '/' . $url);
    $url = $CFG->{db_cgi_url} . "/user.cgi?url=$url&from=$from";
    foreach my $preserve (@{$CFG->{dynamic_preserve}}) {
        my $val = $IN->param($preserve);
        defined $val or next;
        $url .= "&$preserve=" . $IN->escape($val);
    }
    return $url;
}

sub header {
# --------------------------------------------------------------
# Produces an admin header.
#
    my $title = defined $_[0] ? $_[0] : '';
    my $msg   = defined $_[1] ? ($_[1] eq '0' ? '' : $_[1]) : '';
    my $msg2  = defined $_[2] ? ($_[2] eq '0' ? '' : qq~<p><font size="2" face="Tahoma,Arial,Helvetica">$_[2]</font></p>~) : '';

    return <<END_OF_HEAD;
<table border="1" cellpadding="0" cellspacing="0"><tr><td>
    <table bgColor="#ffffff" border="0" cellPadding="3" cellSpacing="3" width="500" valign="top">
      <tr>
        <td align="left" bgColor="navy"><b><font color="#ffffff" size="2" face="Tahoma,Arial,Helvetica">$title</font></b></td>
      </tr>
      <tr>
        <td>
          <p align="center"><b><font color="#000000" size="2" face="Tahoma,Arial,Helvetica">$title</font></b></p>
          <p><font size="2" face="Tahoma,Arial,Helvetica">$msg</font>
        $msg2
          </td>
      </tr>
    </table>
    </td></tr>
</table>
END_OF_HEAD
}

sub fatal {
# --------------------------------------------------------------
# Return a fatal error message to the browser.
#
    die @_ if (GT::Base->in_eval());    # Don't do anything if we are in eval.

    my $msg   = $IN->html_escape(shift);
    my $debug = defined $CFG->{debug_level} ? $CFG->{debug_level} : $DEBUG;

    $IN ||= new GT::CGI;
    print $IN->header();


# Use a custom header if one is defined.
    if (defined $CFG and exists $CFG->{error_message} and $CFG->{error_message}) {
        $CFG->{error_message} =~ s,<%error%>,$msg,g;
        $CFG->{error_message} =~ s,<%environment%>,environment(),eg;
        print $CFG->{error_message};
    }
# Otherwise, print our standard header.
    else {
        print "<p><font face='Tahoma,Arial,Helvetica' size=2>A fatal error has occured:</font></p><blockquote><pre>$msg</pre></blockquote><p><font face='Tahoma,Arial,Helvetica' size=2>Please enable debugging in setup for more details.</font></p>\n";
        if ($debug) {
            print environment();
        }
    }
}

$COMPILE{environment} = __LINE__ . <<'END_OF_SUB';
sub environment {
# --------------------------------------------------------------------
# Return HTML formatted environment for error messages.
#
    my $info = '<pre>';
    my ($oserr, $evalerr) = ($@, $!);

# Stack trace.
    $info .= "<b>Stack Trace</b>\n======================================\n";
    $info .= GT::Base::stack_trace('Links', 1, 1);
    $info .= "\n";

# Print GT::SQL error if it exists.
    $info .= "<b>System Information</b>\n======================================\n";
    if (my @user = eval { getpwuid($>) }) {
        $info .= "Current user: $user[0] ($>)\n";
    }
    $info .= "Perl version: " . ($^V ? sprintf("%vd", $^V) : $]) . "\n";
    $info .= "Gossamer Links version: $Links::VERSION\n" if $Links::VERSION;
    $info .= "GT::SQL version: $GT::SQL::VERSION\n" if $GT::SQL::VERSION;
    $info .= "GT::Template version: $GT::Template::VERSION\n" if $GT::Template::VERSION;
    $info .= "DBI.pm version: $DBI::VERSION\n" if $DBI::VERSION;
    $info .= "Running under mod_perl: " . (MOD_PERL ? "Yes (version " . MOD_PERL . ")" . (MOD_PERL >= 1.99 ? ', mod_perl 2 detected' : '') : "No") . "\n";
    $info .= "Running under SpeedyCGI: " . (SPEEDY ? "Yes (version " . SPEEDY . ")" : "No") . "\n";
    $info .= "\@INC = \n\t" . join("\n\t", @INC) . "\n";
    $info .= "GT::SQL::error = " . $IN->html_escape($GT::SQL::error) . "\n" if $GT::SQL::error;
    $info .= "DBI::errstr = " . $IN->html_escape($DBI::errstr) . "\n" if defined $DBI::errstr;
    $info .= "\$\@: " . $IN->html_escape($oserr) . "\n" if $oserr;
    $info .= "\$!: " . $IN->html_escape($evalerr) . "\n" if $evalerr;
    $info .= "\n";

# CGI Parameters and Cookies.
    if ($IN and ref($IN) eq 'GT::CGI') {
        if ($IN->param) {
            $info .= "<b>CGI Input</b>\n======================================\n";
            foreach (sort $IN->param) {
                $info .= $IN->html_escape($_) . " => " . $IN->html_escape($IN->param($_)) . "\n";
            }
            $info .= "\n";
        }
        if ($IN->cookie) {
            $info .= "<b>CGI Cookies</b>\n======================================\n";
            foreach (sort $IN->cookie) {
                $info .= $IN->html_escape($_) . " => " . $IN->html_escape($IN->cookie($_)) . "\n";
            }
            $info .= "\n";
        }
    }

# Environment info.
    $info  .= "<b>Environment</b>\n======================================\n";
    foreach (sort keys %ENV) {
        $info .= $IN->html_escape($_) . " => " . $IN->html_escape($ENV{$_}) . "\n";
    }

    $info .= "</pre>";
    return $info;
}
END_OF_SUB

$COMPILE{module_environment} = __LINE__ . <<'END_OF_SUB';
sub module_environment {
    my @loop;
    for (sort {
        my $apath = $a !~ m{^\w+(?:/\w+)*\.p[ml]$};
        my $bpath = $b !~ m{^\w+(?:/\w+)*\.p[ml]$};
        return 1 if $apath and not $bpath;
        return -1 if $bpath and not $apath;
        return $a cmp $b;
    } keys %INC) {
        my %info = (inc_path => $INC{$_});
        (my $pkg = $_) =~ s|/|::|g;
        my $m = ($pkg =~ s/\.pm$// and $pkg =~ /^\w+(?:::\w+)*$/);
        my $ver;
        $ver = ${"${pkg}::VERSION"} if $m;
        $m = $m ? $pkg : $_;
        if ($m eq $INC{$_}) {
            $info{file_type} = 'file';
        }
        else {
            @info{qw/file_type module module_version/} = ('module', $m, $ver);
        }
        push @loop, \%info;
    }

    return { modules => \@loop, current_pid => $$ };
}
END_OF_SUB

sub date_to_time {
# --------------------------------------------------------------
# Taken from GForum
# 
    my $date = shift;
    my $lt;
    my @localtime;
    DATE: {
        (uc $date eq 'NOW') and (@localtime = localtime), last DATE;

# localtime format
        $date =~ m|^\w+ \w{3} \d{1,2} \d{1,2}:\d{1,2}:\d{1,2} \d{4}$|  and (@localtime = @{GT::Date::parse_format($date, '%ddd% %mmm% %d% %H%:%M%:%s% %yyyy%')}), last DATE;
        $date =~ m|^\w+ \w{3}  \d{1,2} \d{1,2}:\d{1,2}:\d{1,2} \d{4}$| and (@localtime = @{GT::Date::parse_format($date, '%ddd% %mmm%  %d% %H%:%M%:%s% %yyyy%')}), last DATE;

# Okay, it wasn't simply them modifying what was displayed, so let's try some other common formats:
# just the date, no time:
# yyyy/mm/dd
        $date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2}$| and (@localtime = @{GT::Date::parse_format($date, "%yyyy%$1%m%$2%d%")}), last DATE;
# 12 hour time:
# yyyy/mm/dd hh:MM [AP]M
        $date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2} \d{1,2}[Hh:]\d{1,2} [AaPp][Mm]$| and (@localtime = @{GT::Date::parse_format($date, "%yyyy%$1%m%$2%d% %h%:%M% %tt%")}), last DATE;
# yyyy/mm/dd hh:MM:ss [AP]M
        $date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2} \d{1,2}:\d{1,2}:\d{1,2} [AaPp][Mm]$| and (@localtime = @{GT::Date::parse_format($date, "%yyyy%$1%m%$2%d% %h%:%M%:%s% %tt%")}), last DATE;
# 24 hour time:
# yyyy/mm/dd HH:MM
        $date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2} \d{1,2}:\d{1,2}$| and (@localtime = @{GT::Date::parse_format($date, "%yyyy%$1%m%$2%d% %H%:%M%")}), last DATE;
# yyyy/mm/dd HH:MM:ss
        $date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2} \d{1,2}:\d{1,2}:\d{1,2}$| and (@localtime = @{GT::Date::parse_format($date, "%yyyy%$1%m%$2%d% %H%:%M%:%s%")}), last DATE;
# Common formats that can't be recognized:
# dd/mm/yyyy - These two are conflicting US/European formats and so it would
# mm/dd/yyyy - be impossible to figure out which one you are trying to use.

# First, try the admin format:
        ref($lt = GT::Date::parse_format($date, GT::Date::FORMAT_DATE)) eq 'ARRAY' and (@localtime = @$lt), last DATE;
    }

    return scalar @localtime ? GT::Date::timelocal(@localtime) : undef;
}

sub paging {
# --------------------------------------------------------------
# General-purpose paging code (taken from GForum)
# Returns paging variables for templates (but can be used elsewhere).
# Takes 4 arguments: number of hits, hits per page, the current page, and the number of pages to show.
# Takes 1 additional optional argument - true or false, indicating whether or not a ... system will be
#   used. If set, one extra number will be returned if there is just one extra number needed, and a
#   'dotdotdot' variable will be available as 1 if ... is needed.
#   Example: when displaying paging of 9 with 11 pages, you would get:
#     1 2 3 4 5 6 7 8 9 and you would have the "dotdotdot" variable set, so you would put a ... and then 11.
#   Now, if you were displaying paging of 9 with 10 pages, you would actually get _10_ numbers:
#     1 2 3 4 5 6 7 8 9 10 and the "dotdotdot" wouldn't be set, so you wouldn't put the ... 10, since
#     1 2 3 4 5 6 7 8 9 ... 10 would look silly.
# Returned is a hashref: { paging => LOOP/ARRAYREF, top_page => INTEGER }, and possibly dotdotdot => 1
# Inside the loop you have: <%page_num%> and <%is_current_page%>.
#
    shift if @_ and UNIVERSAL::isa($_[0], __PACKAGE__); # Can be called as function or method
    my ($num_hits, $max_hits, $current_page, $disp_pages, $want_dotdotdot) = @_;

    $disp_pages ||= 20;
    my $num_pages = int($num_hits / $max_hits);
    $num_pages++ if $num_hits % $max_hits;
    my ($start, $end);
    if ($num_pages <= $disp_pages) {
        $start = 1;
        $end = $num_pages;
    }
    elsif ($current_page >= $num_pages - $disp_pages / 2) {
        $end = $num_pages;
        $start = $end - $disp_pages + 1;
    }
    elsif ($current_page <= $disp_pages / 2) {
        $start = 1;
        $end = $disp_pages;
    }
    else {
        $start = $current_page - int($disp_pages / 2) + 1;
        $start-- if $disp_pages % 2;
        $end = $current_page + int($disp_pages / 2);
    }
    my $need_dotdotdot;
    if ($want_dotdotdot) {
        if ($num_pages == $end + 1) {
            ++$end;
        }
        elsif ($num_pages > $end) {
            $need_dotdotdot = 1;
        }
    }
    my @pages = map +{ page_num => $_, (($_ == $current_page) ? (is_current_page => 1) : ()) }, $start .. $end;
    return {
        paging => \@pages,
        top_page => $num_pages,
        ($want_dotdotdot && $need_dotdotdot ? (dotdotdot => 1) : ())
    };
}

sub limit_offset {
# -----------------------------------------------------------------------------
# Takes a list of options, verifies mh/nh values, then returns
# ($limit, $offset, $nh) - $nh is really just (offset * mh + 1).
#
# Options accepted are:
# ($mh, $nh, $default_mh)
# ($mh, $nh)
# ($default_mh)
# ()
#
# The first two take the $mh and $nh values, the latter two read them from
# $IN->param.  $default_mh is used if $mh is not set (or is invalid) - if not
# specified, it defaults to 25.  $nh, if unset, defaults to 1.
#
    my ($mh, $nh, $default_mh);
    if (@_ >= 2) {
        ($mh, $nh, $default_mh) = @_;
    }
    else {
        $mh = $IN->param('mh');
        $nh = $IN->param('nh');
        $default_mh = $_[0];
    }

    $default_mh = 25 unless $default_mh and $default_mh =~ /^\d+$/;

    $mh = $default_mh unless $mh and $mh =~ /^\d+$/;
    $nh = 1 unless $nh and $nh =~ /^\d+$/;

    return ($mh, $mh * ($nh - 1), $nh);
}

sub debug {
# --------------------------------------------------------------
# Display debug message to stderr.
#
    my $msg = shift;
    warn "Links ($$): $msg\n";
    if ($DEBUG > 1) {
        GT::SQL->stack_trace;
    }
}

1;