# ==================================================================
# Gossamer List - enhanced mailing list management system
#
#   Website  : http://gossamer-threads.com/
#   Support  : http://gossamer-threads.com/scripts/support/
#   CVS Info :                     
#   Revision : $Id: GList.pm,v 1.68 2004/07/15 16:38:51 bao Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# Redistribution in part or in whole strictly prohibited.  Please
# see LICENSE file for full details.
# ==================================================================
#

package GList;
# ==================================================================

use 5.004_04;
use strict;
use GList::Custom; # Empty module for end-users to modify, if special code is
                   # required.  Won't be overwritten when upgrading.

use vars qw($VERSION $DEBUG $IN $DB $CFG $USER $GLOBALS $GLOB_NO_SUBS $LANGUAGE $LANG_TPL $error @ISA @EXPORT_OK %EXPORT_TAGS $MN_SELECTED);
use GT::Base qw/:all/;
use GT::CGI;
use GT::Config;
use GT::Delay;
use GT::Template;
use GT::Plugins;
use GList::Config;
require Exporter;

$DEBUG    = 0;
$VERSION  = '1.1.1';

use constants
    READ_SIZE => 65_536,

    ADMINISTRATOR     => 1,
    LIMITED_USER      => 2,
    UNLIMITED_USER    => 3,
    UNVALIDATED_USER  => 4,

    TRACK_OPEN_HTML => <<HTML,
<img src="<%cgi_url%>/glist.cgi?do=user_open;eml_code=<%eml_code%>;mailing=<%mailing%>" width="1" height="1">
<iframe src="<%cgi_url%>/glist.cgi?do=user_open;eml_code=<%eml_code%>;mailing=<%mailing%>" width="1" height="1"></iframe>
<table border=0 cellpadding=0 cellspacing=0 height="1" width="1"><tr><td background="<%cgi_url%>/glist.cgi?do=user_open;eml_code=<%eml_code%>;mailing=<%mailing%>"></td></tr></table>
HTML

    TRACK_OPEN_HTML_NOIFRAME => <<HTML,
<img src="<%cgi_url%>/glist.cgi?do=user_open;eml_code=<%eml_code%>;mailing=<%mailing%>" width="1" height="1">
<table border=0 cellpadding=0 cellspacing=0 height="1" width="1"><tr><td background="<%cgi_url%>/glist.cgi?do=user_open;eml_code=<%eml_code%>;mailing=<%mailing%>"></td></tr></table>
HTML

    TRACK_CLICK_URL => "<%cgi_url%>/glist.cgi?do=user_click;mailing=<%mailing%>";


@ISA = 'Exporter';
@EXPORT_OK = qw/
    $VERSION $MOD_PERL $DEBUG $IN $DB $CFG $USER $GLOBALS $LANGUAGE $MN_SELECTED
    ADMINISTRATOR LIMITED_USER UNLIMITED_USER UNVALIDATED_USER TRACK_OPEN_HTML TRACK_OPEN_HTML_NOIFRAME TRACK_CLICK_URL
/;
%EXPORT_TAGS = (
    all       => \@EXPORT_OK,
    objects   => [qw/$IN $DB $CFG $USER $MN_SELECTED/],
    user_type => [qw/ADMINISTRATOR LIMITED_USER UNLIMITED_USER UNVALIDATED_USER/],
    tracks    => [qw/TRACK_OPEN_HTML TRACK_OPEN_HTML_NOIFRAME TRACK_CLICK_URL/]
);

my $basic_tables;

sub init {
# -----------------------------------------------------------------------------
# This subroutine should be called on every request with a single argument: the
# path to the private library directory.
#

# If called as a method, discard the class/object:
    shift if @_ and UNIVERSAL::isa($_[0], __PACKAGE__);
    my $lib_path = shift || '.';

    if (PERSIST) {
        GT::SQL->reset_env() if $INC{'GT/SQL.pm'};
        GT::Plugins->reset_env();
        GT::CGI->reset_env();
    }

# Get our config object.
    $CFG = GList::Config->new($lib_path);

    my $debug = $CFG->{debug_level} || $DEBUG;

# create input and sql objects
    $IN = GT::CGI->new();

    if ($DB and not ref $DB eq 'GT::Delay') {
        $DB = GT::SQL->new({
            def_path => "$CFG->{priv_path}/defs",
            cache    => 1,
            debug    => $debug
        });
    }
    else {
        $DB = GT::Delay(
            'GT::SQL' => 'HASH',
            {
                def_path => "$CFG->{priv_path}/defs",
                cache => 1,
                debug => $debug
            }
        );
    }

# Set plugin debug level.
    $GT::Plugins::DEBUG = $debug;

    $USER = $GLOBALS = $GLOB_NO_SUBS = $LANGUAGE = $LANG_TPL = $basic_tables = undef;
}

sub init_user {
# -----------------------------------------------------------------------------
# Check to see if the request is for a valid user, if so, set $USER to the
# user.
#

# Authenticate the user.
    require GList::Authenticate;
    GList::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, $session_id, $use_cookie);
    if (defined $username && defined $password) {
        unless (test_connection()) { # Database connection is failed
            if ( GList::Authenticate::auth('admin_valid_user', { username => $username, password => $password }) ) {
                $USER->{username} = $username;
                $USER->{usr_type} = ADMINISTRATOR;
                return $USER;
            }
        }
        elsif (GList::Authenticate::auth('valid_user', { username => $username, password => $password })) {
            $valid_user = $username;
        }
    }
    else {
        unless (test_connection()) { # Database connection is failed
            my $results = GList::Authenticate::auth('admin_valid_session');
            if ($results) {
                $USER = $results;
                $USER->{usr_type} = ADMINISTRATOR;
                return $USER;
            }
            return;
        }
        my $results = GList::Authenticate::auth('valid_session');
        $valid_user = $results->{user_name};
        $session_id = $results->{session_id};
        $use_cookie = $results->{use_cookie};
    }
    return if !$valid_user;

# We have a valid_user, now let's get the user from database
    $USER = GList::Authenticate::auth('get_user', { username => $valid_user });
    return 1 if !$USER;

    if ($CFG->{signup_email_validate} and $USER->{usr_validate_code}) {
        return 2;
    }

    if ($CFG->{signup_admin_validate} and $USER->{usr_type} == UNVALIDATED_USER) {
        return 3;
    }

    $USER->{use_cookie} = $use_cookie;
    $USER->{session_id} = $session_id;

    return $USER;
}

sub test_connection {
# -----------------------------------------------------------------------------
# Test the database connection by trying to establish a connection.  Returns
# 1 on success, nothing on connection error.  In addition to the database
# connection, this also makes sure that the Users and Users_Sessions tables
# are working, since you need them at a minimum to get to the SQL setup page.
#
    $DB->driver or return;
    GT::SQL::Table->new(connect => $DB->{connect})->connect or return;
    unless ($basic_tables) {
        defined $DB->table('Users')->count({ usr_username => undef }) or return;
        defined $DB->table('Users_Sessions')->count({ session_id => undef }) or return;
        $basic_tables++;
    }

    return 1;
}

sub environment {
# --------------------------------------------------------------------
# Return HTML formatted environment for error messages.
#
    my $info = '<PRE>';

# Stack trace.
    my $i = 0;
    $info .= "<B>Stack Trace</B>\n======================================\n";
    $info .= GT::Base::stack_trace('GList', 1);
    $info .= "\n\n";

# Print GT::SQL error if it exists.
    $info .= "<B>System Information</B>\n======================================\n";
    $info .= "Perl Version: $]\n";
    $info .= "GList SQL Version: $GList::VERSION\n" if ($GList::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 .= "GT::SQL::error = $GT::SQL::error\n" if ($GT::SQL::error);
    $info .= "\@INC = \n\t" . join ("\n\t", @INC) . "\n";
    $info .= "\$\@: $@\n" if ($@);
    $info .= "\n";

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

# Environement info.
    $info  .= "<B>ENVIRONMENT</B>\n======================================\n";
    foreach (sort keys %ENV) { $info .= "$_ => $ENV{$_}\n"; }
    $info .= "</PRE>";

    return $info;
}

sub display {
# -----------------------------------------------------------------
# Returns a specified template parsed.
#
    my ($template, $args) = @_;

    my $template_set = $IN->param('t') || $CFG->{template_set};
    my $template_dir = "$CFG->{priv_path}/templates/$template_set";
    my $http         = $IN->url(absolute => 0, query_string => 0);

# Add config vars.
    foreach my $key (keys %$CFG) {
        $args->{$key} = $CFG->{$key} unless (exists $args->{$key});
    }

# Used for HTML editor
    my %browser = $IN->browser_info;
    delete $browser{is_ie} if $browser{is_ie} and $browser{ie_version} < 5.5;
    @$args{keys %browser} = values %browser;

    $args->{html}->{in}  = $IN;
    $args->{html}->{sql} = $DB;
    $args->{html}->{cfg} = $CFG;
    $args->{selected_menu} = $MN_SELECTED;

# Loads template globals
    load_globals();

# Escapes HTML code
    my $cgi     = $IN->get_hash();
    my $content = $cgi->{msg_content_html};
    if ( $content ) {
        $content =~ s,\r\n,\n,g;
        $cgi->{msg_content_html} = $IN->html_escape($content);
    }

    print $IN->header;
    GT::Template->parse($template, [$args, $cgi, $GLOBALS, $USER || {}], { print => 1, root => $template_dir });
}

sub set_default_template {
#-----------------------------------------------------------
# Add default email template when adding a user
#
    my ($fname, $userid) = @_;
    require GT::Mail::Editor;
    my $email = GT::Mail::Editor->new(dir => "$CFG->{priv_path}/templates", template => $CFG->{template_set});
    $email->load($fname);
    my $hsh = {};
    my $cgi = $IN->get_hash();

    $fname =~ s/\.eml//;
    $hsh->{tpl_user_id_fk} = $userid;
    $hsh->{tpl_name}   = $fname;
    $hsh->{tpl_to}     = $email->{headers}->{To};
    $hsh->{tpl_from}   = $email->{headers}->{From};
    $hsh->{tpl_subject}= $email->{headers}->{Subject};
    $hsh->{tpl_body}   = $email->{body};

    $DB->table('EmailTemplates')->insert($hsh);
}

sub add {
#--------------------------------------------------------------------
# Add a record
#
    my ($table, $prefix, $cgi) = @_;

    my $db = $DB->table($table) or return $GT::SQL::error;

# Turn arrays into delimited fields
    $cgi ||= format_insert_cgi($db);

# Save the current time
    if ( $table eq 'Messages' ) {
        $cgi->{msg_created} = time;
        if ($cgi->{msg_content_html} =~ /^\s*<html>\s*<BODY\s*class=object\s*\s*src="">\s*<\/BODY>\s*<\/html>\s*$/mi or
            $cgi->{msg_content_html} =~ /^\s*<html>\s*<body\s*src="">\s*<\/body>\s*<\/html>\s*$/mi or
            $cgi->{msg_content_html} =~ /^\s*<html>\s*<BODY\s*class=object\s*\s*src=""><p>\&nbsp;<\/p><\/BODY>\s*<\/html>\s*$/mi or
            $cgi->{msg_content_html} =~ /^\s*<html>\s*<BODY\s*src=""><P>\&nbsp;<\/P><\/BODY>\s*<\/html>\s*$/mi) {
            $cgi->{msg_content_html} = "";
        }
    }
    elsif ( $table eq 'Lists' ) {
        $cgi->{lst_date_created} = time;
    }

# Add the record's owner
    $cgi->{$prefix.'_user_id_fk'} = $USER->{usr_username};

# Setup the language for GT::SQL.
    local $GT::SQL::ERRORS->{ILLEGALVAL} = language('ADD_ILLEGALVAL')   if ( language('ADD_ILLEGALVAL') );
    local $GT::SQL::ERRORS->{UNIQUE}     = language('ADD_UNIQUE')       if ( language('ADD_UNIQUE') );
    local $GT::SQL::ERRORS->{NOTNULL}    = language('ADD_NOTNULL')      if ( language('ADD_NOTNULL') );

    my $cols = $db->cols;

    foreach my $c ( keys % $cols ) {
        my $regex = $cols->{$c}->{form_regex};
        if ( $regex and $cgi->{$c} !~ /$regex/ ) {
            $error .= language('SYS_REGEXFAIL', $cols->{$c}->{form_display});
        }
    }
    return if ( $error );
    if ( defined (my $ret = $db->add($cgi)) ) {
        return $ret;
    }
    else {
        local $^W;
        $error = $GT::SQL::error;
    }
}

sub modify {
#--------------------------------------------------------------------
# Modify a record
#
    my ($table, $prefix, $cgi) = @_;

    my $db = $DB->table($table) or return $GT::SQL::error;

# Format arrays for insertion
    $cgi ||= format_insert_cgi($db, $cgi);

# Check if users can modify only their own records except Administrator
    if ( $USER->{usr_type} != ADMINISTRATOR ) {
        my $lookup = {};
        my $pk     = $db->pk;
        foreach (@$pk) { $lookup->{$_} = $IN->param($_); }
        my $rs = $db->get($lookup);

        if ( $rs->{$prefix.'_user_id_fk'} ne $USER->{usr_username} ) {
            $error = language('SYS_PER_DENIED');
            return;
        }
    }

# Setup the language for GT::SQL.
    local $GT::SQL::ERRORS->{ILLEGALVAL} = language('ADD_ILLEGALVAL')   if ( language('ADD_ILLEGALVAL') );
    local $GT::SQL::ERRORS->{UNIQUE}     = language('ADD_UNIQUE')       if ( language('ADD_UNIQUE') );
    local $GT::SQL::ERRORS->{NOTNULL}    = language('ADD_NOTNULL')      if ( language('ADD_NOTNULL') );

    if ( $table eq 'Messages' ) {
        if ($cgi->{msg_content_html} =~ /^\s*<html>\s*<BODY\s*class=object\s*\s*src="">\s*<\/BODY>\s*<\/html>\s*$/mi or
            $cgi->{msg_content_html} =~ /^\s*<html>\s*<body\s*src="">\s*<\/body>\s*<\/html>\s*$/mi or
            $cgi->{msg_content_html} =~ /^\s*<html>\s*<BODY\s*class=object\s*\s*src=""><p>\&nbsp;<\/p><\/BODY>\s*<\/html>\s*$/mi or
            $cgi->{msg_content_html} =~ /^\s*<html>\s*<BODY\s*src=""><P>\&nbsp;<\/P><\/BODY>\s*<\/html>\s*$/mi) {
            $cgi->{msg_content_html} = "";
        }
        if ($cgi->{msg_mode} eq 'text') {
            $cgi->{msg_content_html} = '';
        }
    }
    if ( $db->modify($cgi) ) {
        return;
    }
    else {
        local $^W;
        $error = $GT::SQL::error;
    }
}

sub delete {
#--------------------------------------------------------------------
# Delete records
#
    my ($table, $prefix, $cgi, $msg) = @_;

    my $db = $DB->table($table);

# Create a cgi object
    $cgi ||= $IN->get_hash();

# If they selected only one record to delete we still need an array ref
    my $mod = ( ref $cgi->{modify} eq 'ARRAY' ) ? $cgi->{modify} : [$cgi->{modify}];

# Need to know the names of the columns for this Table.
    my @columns = keys %{$db->cols};

# Need to know the number of records modified
    my $rec_modified = 0;
    my $rec_declined = 0;


    if ( $table eq 'Messages' or $table eq 'MailingIndex' )  {
        require GT::File::Tools;
    }

# For through the record numbers. These are the values of the
# check boxes
    foreach my $rec_num ( @{$mod} )  {
        my $change = {};
        foreach my $column ( @columns ) {
            $change->{$column} = $cgi->{"$rec_num-$column"} if ( $cgi->{"$rec_num-$column"} );
        }

# Check for delete own record
        if ( $USER->{usr_type} != ADMINISTRATOR ) { # As a user
            my $rs = $db->get($change);
            next if ( !$rs );
            if ( $rs->{$prefix.'_user_id_fk'} ne $USER->{usr_username} ) {
                $rec_declined++; next;
            }
        }
        next unless ( keys %$change );
        if ( $table eq 'MailingIndex' ) {
            if ( int $cgi->{fd} and $cgi->{fd} == 3 ) { # Deletes records
                my $info = $db->get($change) || {};
                if ( $USER->{usr_type} == ADMINISTRATOR or !$info->{mli_Done} ) { # Admin user
                    my $ret = $db->delete($change);
                    if ( defined $ret and ($ret != 0) ) {
                        $rec_modified++;
                    }
                }
                else {
                    $db->update({ mli_delete => '2', mli_cat_id_fk => 0, mli_root => '0' }, $change);
                    $rec_modified++;
                }
            }
            else { # Marks records
                $db->update({ mli_delete => '1', mli_cat_id_fk => 0, mli_root => '0' }, $change);
                $rec_modified++;
            }
        }
        else {
            my $ret = $db->delete($change) or die $GT::SQL::error;
            if ( defined $ret and ($ret != 0) ) {
                $rec_modified++;
            }
        }

# Remove attachments
        my $id = $IN->param("$rec_num-msg_id");
        if ( $table eq 'Messages' and $id )  {
            remove_attachments($id, 'messages');
        }

        $id = $IN->param("$rec_num-Mailing");
        if ( $table eq 'MailingIndex' and $id and $cgi->{fd} == 3 )  {
            remove_attachments($id, 'mailings');
        }
    }
    $msg ||= ( $rec_declined ) ? GList::language('SYS_DELETED2', $rec_modified, $rec_declined) : GList::language('SYS_DELETED', $rec_modified);
    return $msg;
}

sub send {
#--------------------------------------------------------
# Send a message by using GT::Mail
#     
    my ($head, $content, $attachments, $attach_path, $charset) = @_;

    $attachments ||= [];
    $charset     ||= 'us-ascii';
    require GT::Mail;
    $GT::Mail::error ||= ''; # Silence -w

    my $m = GT::Mail->new(debug => $CFG->{debug_level}, header_charset => $charset);
    my $parts;
    if ( $content->{text} and $content->{html} ) {
        $parts = $m->new_part('Content-Type' => "multipart/alternative; charset=\"$charset\"");
        $parts->parts($m->new_part(
            'Content-Type' => "text/plain; charset=\"$charset\"",
            body_data      => $content->{text},
            encoding       => 'quoted-printable'
        ));
        $parts->parts($m->new_part(
            'Content-Type' => "text/html; charset=\"$charset\"",
            body_data      => $content->{html},
            encoding       => 'quoted-printable'
        ));
    }
    elsif (@$attachments) {
        my $msg  = $content->{text} || $content->{html};
        my $type = ( $msg =~ m/(<html>|<body>)/i ? "text/html" : "text/plain" );
        $type  = "text/html" if ($content->{html});
        $parts = $m->new_part(
            'Content-Type' => "$type; charset=\"$charset\"",
            body_data      => $msg,
            encoding       => 'quoted-printable'
        );
    }
    else {
        my $msg  = $content->{text} || $content->{html};
        my $type = ( $msg =~ m/(<html>|<body>)/i ? "text/html" : "text/plain" );
        $type  = "text/html" if ($content->{html});
        $parts = $m->new_part(
            'Content-Type' => "$type; charset=\"$charset\"",
            encoding       => 'quoted-printable'
        );
        $head->{body_data} = $msg;
    }

# Handle the attachments
    if (@$attachments) {
        my $apart = $m->new_part('Content-Type' => 'multipart/mixed');
        $apart->parts($parts);
        for (@$attachments) {
            my $id           = $_->{att_id} || $_->{mat_id};
            my $filename     = $_->{mat_file_name} || $_->{att_file_name};
            my $content_type = _load_mime("$attach_path/$id", $filename);
            $apart->parts($m->new_part(
               body_path   => "$attach_path/$id",
               encoding    => '-guess',
               filename    => $filename,
               'Content-Type' => $content_type
            ));
        }
        $parts = $apart;
    }

    $head->{'Content-Type'} = $parts->get('Content-Type');

    my $mail = GT::Mail->new(
        %$head,
        debug          => $CFG->{debug_level},
        header_charset => $charset,
    );
    for ($parts->parts()) {
        $mail->attach($_);
    }

    $mail->send(
        smtp      => $CFG->{smtp_server},
        sendmail  => $CFG->{mail_path},
    ) or warn $GT::Mail::error;
}

sub _search_check {
#--------------------------------------------------------------------
#
    my ($cols, $cgi) = @_;
    foreach (keys % $cols) {
        my ($c) = $_ =~ /\.([^.]+)$/;
        $c ||= $_;
        if (exists $cgi->{$c} and $cgi->{$c}) {
            return 1;
        }
        if ($cgi->{"$c-ge"} or $cgi->{"$c-le"} or $cgi->{"$c-gt"} or $cgi->{"$c-lt"}) {
            return 1;
        }
    }
    return;
}

sub search {
#--------------------------------------------------------------------
# Search engine
#
    my $opts = ref $_[0] eq 'HASH' ? shift : { @_ };
    my $cgi         = $opts->{cgi};
    my $db          = $opts->{db};
    my $prefix      = $opts->{prefix};
    my $based_on    = $opts->{based_on};
    my $skip_user   = $opts->{skip_user};
    my $search_check= $opts->{search_check};
    my $search_alpha= $opts->{search_alpha};
    my $search_col  = $opts->{search_col};
    my $return_msg  = $opts->{return_msg};
    my $select_all  = $opts->{select_all};
    my $show_user   = $opts->{show_user};
    my $int_field   = $opts->{int_field};
    $return_msg   ||= uc($prefix).'_RESULTS';

    my $user_field  = $prefix."_user_id_fk";
    my $nh          = $cgi->{nh} || 1;
    my $mh          = $cgi->{mh} || 25;
    my $ma          = $cgi->{ma} || '';
    my $bg          = ( $nh == 1 ) ? 0 : ( $nh - 1 ) * $mh;
    my $sb          = $cgi->{sb} || $opts->{sb};
    my $so          = $cgi->{so} || $opts->{so};
    my $cols        = $db->cols;
    my $table_name  = $db->name;
    my $db_prefix   = $DB->prefix;
    $table_name =~ s/^$db_prefix//;

    $sb ||= $opts->{sb};
    $so ||= $opts->{so} || 'ASC';
    if ($search_check and !$cgi->{keyword} and !_search_check($cols, $cgi)) {
        return { error => GList::language('SYS_SEARCH_ERROR') };
    }

# Require GT's modules
    require GT::SQL::Condition;
    require GT::Date;

    my ($cd, @words);
    my $query = '';
    if ( $cgi->{keyword} and $cgi->{keyword} ne '*' ) { # keyword search
        $cd = new GT::SQL::Condition('OR');
        if ( $ma ) { # match any
            @words = split(/\s/, $cgi->{keyword});
        }
        else {
            push @words, $cgi->{keyword};
        }

        foreach my $c ( keys % $cols ) {
            if ( $cols->{$c}->{weight} ) { # search weight
                foreach my $w ( @words ) {
                    $cd->add($c, 'like', "%$w%");
                }
            }
        }
        $query = "keyword=$cgi->{keyword};";
    }
    else {
        my $bool = ( $ma ) ? 'OR' : 'AND';
        $cd      = new GT::SQL::Condition($bool);
        if ($search_alpha) {
            if ( $search_col and $search_alpha eq 'other') { # for Subscribers table only
                my $tmp = GT::SQL::Condition->new('OR');
                $tmp->add($search_col => '<' => '0');
                $tmp->add(GT::SQL::Condition->new($search_col => '>=' => ':', $search_col => '<' => 'a'));
                $tmp->add($search_col => '>=' => '[');
                $cd->add($tmp);
                $query .= 'alpha=other;';
            }
            elsif ( $search_col and $search_alpha eq 'number') { # for Subscribers table only
                my $tmp = GT::SQL::Condition->new($search_col => '>=' => '0', $search_col => '<' => ':');
                $cd->add($tmp);
                $query .= 'alpha=number;';
            }
            else {
                $cd->add($search_col, 'like', "$search_alpha%");
            }
        }

        foreach my $c ( keys % $cols ) {
            my $tc = $c;
            if ( $based_on ) {
                $tc =~ s/$based_on\.//;
            }
            next if ( $c and $cgi->{$tc} and ( $c eq $user_field or $cgi->{$tc} eq '*' ));
            if ( $cols->{$c}->{type} =~ /date|datetime|timestamp/mi or !$cgi->{$tc} ) { # DATE fields
                if ( defined $cgi->{$tc} and $cgi->{$tc} eq '0' ) {
                    $cd->add($c, $cgi->{"$tc-opt"} || '=', $cgi->{$tc} );
                    $query .= "$tc=0;";
                }
                else {
                    my $tmp = {'le' => '<=', 'ge' => '>=', 'lt' => '<', 'gt' => '>'};
                    my $format = $USER->{usr_date_format} || '%mm%-%dd%-%yyyy%';
                    foreach my $o (keys % {$tmp} ) {
                        next if ( !$cgi->{"$tc-$o"} );
                        my $v;
                        if ($int_field) {
                            $v = $cgi->{"$tc-$o"};
                        }
                        else {
                            $cgi->{"$tc-$o"} .= ( $o eq 'le' or $o eq 'lt' ) ? ' 23:59:58' : ' 00:00:01';
                            $v = GT::Date::timelocal(GT::Date::parse_format($cgi->{"$tc-$o"}, "$format %hh%:%MM%:%ss%"));
                        }
                        $cd->add($c, $tmp->{$o}, $v);
                        $query .= "$tc-$o=".$cgi->{"$tc-$o"}.';';
                    }
                }
            }
            elsif ( $cgi->{"$tc-opt"} ) {
                $cd->add($c, $cgi->{"$tc-opt"}, $cgi->{$tc});
                $query .= "$tc=$cgi->{$tc};$c-opt=".$cgi->{"$tc-opt"}.";";
            }
            elsif ( $cols->{$c}->{type} =~ /char|varchar|text/mi ) { # TEXT fields
                $cd->add($c, 'like', "%$cgi->{$tc}%");
                $query .= "$tc=$cgi->{$tc};";
            }
            else {
                $cd->add($c, '=', $cgi->{$tc});
                $query .= "$tc=$cgi->{$tc};";
            }
        }
    }
    $query .= 'ma=1;' if ($ma);
    my @extra = ('cs', 'mn_disable');
    foreach (@extra) {
        $query .= "$_=$cgi->{$_};" if ($cgi->{$_});
    }
    chop $query;

# System users will view their own record only
    my $cond = new GT::SQL::Condition($cd);
    if ( !$skip_user ) {
        if ( $USER->{usr_type} != ADMINISTRATOR ) {
            $cond->add($user_field, '=', $USER->{usr_username});
        }
        elsif ( $cgi->{$user_field} ) {
            my $o = $cgi->{"$user_field-opt"} || '=';
            $cond->add($user_field, $o, $cgi->{$user_field});
        }
        else {
            my $user = load_condition($show_user);
            $cond->add($user_field, $user->{opt}, $user->{id});
        }
    }
# Do the search and count the results.
    if ( !$select_all ) {
        $db->select_options("ORDER BY $sb $so LIMIT $bg, $mh ");
    }
    my $sth = $db->select($cond) or die $GT::SQL::error;
    my $hits= $db->hits;

    return language($return_msg, 0) if ( $hits == 0 );

    if ( $#words == -1 and $cgi->{lu} ) {
        @words = split(/\s/, $cgi->{lu});
    }
    my @output;
    my @colors    = ('#ff8888', '#88ff88', '#8888ff', '#ffff88', '#ff88ff', '#88ffff', '#ffcccc', '#cccc99', '#ffffcc', '#ffccff');
    while ( my $rs = $sth->fetchrow_hashref ) {
        if ( $CFG->{highlight_color} ) {
            if ( $#words != -1 ) {
                foreach my $c ( keys % $cols ) {
                    next if ( !$cols->{$c}->{weight} );
                    my $j = 0;
                    foreach my $i (0..$#words) {
                        $j = 0 if ( $j > $#colors );
                        $rs->{$c} =~ s/$words[$i]/<span style="background-color: $colors[$j]">$words[$i]<\/span>/gi;
                        $j++;
                    }
                }
            }
        }
        push @output, $rs;
    }

    return { hits    => $hits,
             results => \@output,
             msg     => language($return_msg, $hits),
             query   => $query,
             mh      => $mh,
             nh      => $nh,
             lookup  => $cgi->{keyword},
             toolbar_table => $table_name
    };
}

sub remove_attachments {
#-----------------------------------------------------------------------
#
    my ($id, $dir) = @_;

    my $path = "$CFG->{priv_path}/attachments/$dir/" . ($id % 10) . "/$id";
    (-e $path) or return "<font color=red>Invalid path $path!</font>";

    opendir (DIR, $path) or return GList::language('DIR_OPEN_ERR', $path, $!);
    my @list = readdir(DIR);
    closedir (DIR);
    foreach my $file (@list) {
        ($file eq '.')  and next;
        ($file eq '..') and next;
        unlink "$path/$file";
    }
    rmdir $path;
    return;
}

sub load_condition {
#-----------------------------------------------------------------------
# Loads the user listings in a group for searching
# It will be returned a hash
#
    my $show_user = shift;

    my $cgi = $IN->get_hash();
    $show_user ||= $cgi->{users};
    if ( $show_user and $USER->{usr_type} == ADMINISTRATOR) { # For admin
        return { id => $USER->{usr_username}, opt => '<>' };
    }
    else { # Check current user
        return { id => $USER->{usr_username}, opt => '=' };
    }
}

sub get_data {
#--------------------------------------------------------------------
# Get data of a record
#
    my $table = shift;

    my $values;
    my $mod = $IN->param('modify');

    if ( $IN->param('modify') == 0 ) {
        $values = $IN->get_hash;
    }
    else {
        my $lookup = {};
        my $db     = $DB->table($table);
        my $pk     = $db->pk;
        foreach ( @$pk ) { $lookup->{$_} = $IN->param("$mod-$_"); }
        $values = $db->get($lookup, 'HASH');
    }

    return $values;
}

sub format_insert_cgi {
#-----------------------------------------------------------------------------
#
    my ($db, $cgi) = @_;

    $cgi   ||= $IN->get_hash;
    my $cols = $db->cols;
    foreach ( keys % $cols ) {
        if ( !exists $cgi->{$_} and uc($cols->{$_}->{form_type}) eq 'CHECKBOX' ) {
            $cgi->{$_} = '';
        }
        next unless ( ref ($cgi->{$_}) eq 'ARRAY' );
        $cgi->{$_} = join ($GT::SQL::Display::HTML::INPUT_SEPARATOR, sort (@{$cgi->{$_}}));
    }
    return $cgi;
}

sub check_owner {
#--------------------------------------------------------------------
# User can only modify their own record, except admin
#
    my ($table, $pre_fix, $id) = @_;

    my $info = $DB->table($table)->get($id);
    ( $info ) or return "<font color=red>$id does not exist!</font>";

# Users can only modify their own records
    if ( $USER->{usr_type} != ADMINISTRATOR and $info->{$pre_fix.'_user_id_fk'} ne $USER->{usr_username} ) {
        return GList::language('SYS_PER_DENIED');
    }

    return $info;
}

sub check_limit {
#------------------------------------------------------------------------------
# Check account limits
#
    my ($type, $list_id) = @_;
    return if ($USER->{usr_type} != LIMITED_USER);

    $error = '';
    if ($type eq 'list') { # limit number of list
        if ($DB->table('Lists')->count({ lst_user_id_fk => $USER->{usr_username} }) >= $USER->{usr_limit_list}) {
            $error = GList::language('SYS_OVERLIMIT_LIST');
            return 1;
        }
    }
    elsif ($type eq 'sublist') { # limit number of subscribers per list
        if ($DB->table('Subscribers')->count(
            { sub_user_id_fk => $USER->{usr_username}, sub_list_id_fk => $list_id }) >= $USER->{usr_limit_sublist} ) {
            $error = GList::language('SYS_OVERLIMIT_SUBLIST');
            return 1;
        }
    }
    elsif ($type eq 'email30') { # limit number of email sending out in the last 30 days
        require GT::Date;
        require GT::SQL::Condition;
        my $last30    = GT::Date::date_sub(GT::Date::date_get(), 30);
        my $unix_time = date_to_time($last30);
        my $num_sent  = $DB->table('MailingIndex', 'EmailMailings')->count(
            GT::SQL::Condition->new(
                mli_user_id_fk => '='  => $USER->{usr_username},
                eml_sent       => '>=' => $unix_time
            )
        );
        if ( $num_sent >= $USER->{usr_limit_email30} ) {
            $error = GList::language('SYS_OVERLIMIT_EMAIL30');
            return 1;
        }
        return $num_sent;
    }
    return;
}

sub load_language {
# -----------------------------------------------------------------------------
# Loads the language.txt file.  You can either pass in a template set, or let
# it auto-detect from t=, or fall back to the default.
#
    my $t = shift || scalar $IN->param('t') || $CFG->{template_set} || 'gossamer';
    $LANGUAGE = undef if !$LANG_TPL or $LANG_TPL ne $t;
    $LANGUAGE ||= GT::Config->load("$CFG->{priv_path}/templates/$t/language.txt", { create_ok => 1, inheritance => 1, local => 1, header => <<HEADER });
# This file is auto generated and contains a perl hash of
# your language variables for the '$t' template set.
# Generated on: [localtime]

HEADER
    $LANG_TPL = $t;
}

sub load_globals {
# -----------------------------------------------------------------------------
# Loads the globals.txt file into $GLOBALS.  Takes one (optional) value; if
# false or absent, compile_subs will be passed to the GT::Config object, if
# true it will be omitted.
#
    my $no_subs = shift;
    $GLOBALS = undef if $no_subs xor $GLOB_NO_SUBS;
    $GLOBALS ||= GT::Config->load("$CFG->{priv_path}/templates/common/globals.txt", {
        $no_subs ? () : (compile_subs => 'GList'),
        inheritance => 1,
        local => 1,
        cache => 1,
        header => <<'HEADER'
# This file is auto generated and contains a perl hash of
# your template globals.
# Generated on: [localtime]

HEADER
    });
    $GLOB_NO_SUBS = $no_subs;
}

sub language {
# ------------------------------------------------------------------
# Process a language request, it's only loaded once, and saved in
# $LANGUAGE.
#
    require GT::Config;
    my $code = shift || '';

    load_language();

    if (exists $LANGUAGE->{$code}) {
        return @_ ? sprintf($LANGUAGE->{$code}, @_) : $LANGUAGE->{$code};
    }
    else {
        return $code;
    }
}

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   = shift;
    my $debug = defined $CFG->{debug_level} ? $CFG->{debug_level} : $DEBUG;

    $IN ||= new GT::CGI;
    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;
        display('error_form.html', { msg => language('SYS_FATAL', $CFG->{error_message}) });
    }
    else {
        display('error_form.html', { msg => language('SYS_FATAL', $msg) });
    }
    if ($debug) {
        print environment();
    }
}

sub view_file {
#---------------------------------------------------------------
# View a file
#
    my $fn   = $IN->param('fn');
    my $fd   = $IN->param('fd');
    my $type = $IN->param('ft');
    $fn and $fd or return display('error_form.html', { msg => language('SYS_FILE_INVALID') });

# Check file existing
    my $file = $DB->table($type ? 'MessageAttachments' : 'MailingAttachments')->get($fn);
    $file or return display('error_form.html', { msg => language('SYS_FILE_NOT_FOUND', $fn) });

    my $full_file    = "$CFG->{priv_path}/attachments/".(( $type ) ? 'messages' : 'mailings')."/".($fd % 10)."/$fd/$fn";
    my $file_name    = ( $type ) ? 'att_file_name' : 'mat_file_name';
    my $content_type = _load_mime($file->{$file_name});
    my ($ext)        = $full_file =~ /\.([^.]+)$/;
    my $file_size    = -s $full_file;
    if (open DATA, $full_file) {
        if (($content_type =~ m/text/ or -T $full_file) and uc($ext) ne 'PDF') {
            print $IN->header;
        }
        else {
            warn "Content-type: $content_type, Content-Length: $file_size";
            print $IN->header({
                '-type'           => $content_type,
                '-Content-Length' => $file_size,
            });
        }
        binmode STDOUT;
        binmode DATA;
        my $buffer;
        print $buffer while (read(DATA, $buffer, READ_SIZE));
        close DATA;
        return;
    }
    else {
        return ('error_form.html', { msg => language('SYS_FILE_ERR', $fn) });
    }
}

sub download_file {
#--------------------------------------------------------------
# Download a file
#
    my $fn   = $IN->param('fn');
    my $fd   = $IN->param('fd');
    my $type = $IN->param('ft');
    ( $fn and $fd ) or return display('error_form.html', { msg => language('SYS_FILE_INVALID') });

# Check file existing
    my $file = $DB->table(( $type ) ? 'MessageAttachments' : 'MailingAttachments')->get($fn);
    $file or return display('error_form.html', { msg => language('SYS_FILE_NOT_FOUND', $fn) });

    my $full_file = "$CFG->{priv_path}/attachments/".($type ? 'messages' : 'mailings')."/".($fd % 10)."/$fd/$fn";
    my $file_name = $type ? 'att_File_Name' : 'mat_File_Name';
    my $file_size = -s $full_file;
    if (open DATA, $full_file) {
       print $IN->header(
            '-type'                      => 'application/download',
            '-Content-Length'            => $file_size,
            '-Content-Transfer-Encoding' => 'binary',
            '-Content-Disposition'       => \"attachment; filename=$file->{$file_name}"
       );
        binmode STDOUT;
        binmode DATA;
        my $buffer;
        print $buffer while (read(DATA, $buffer, READ_SIZE));
        close DATA;
        return;
    }
    else {
        return ('error_form.html', { msg => language('SYS_FILE_ERR', $fn) } );
    }
}

sub encrypt {
# -------------------------------------------------------------------
    my ($clear_pass, $salt) = @_;
    defined $salt or ($salt = '');
    require GT::MD5::Crypt;
    if (! $salt) {
        my @rand_salt = ('a' .. 'z', 'A' .. 'Z', 0 .. 9, '.', '/');
        for (1 .. 8) { $salt .= $rand_salt[rand @rand_salt]; }
    }
    my $enc_pass = GT::MD5::Crypt::gt_md5_crypt($clear_pass, $salt);
    return $enc_pass;
}

sub date_to_time {
    my ($date, $date_format) = @_;
    my $lt;
    my @localtime;
    require GT::Date;

    $date_format ||= '%yyyy%-%mm%-%dd%';
    DATE: {
    # First, try the admin format:
        ref($lt = GT::Date::_parse_format($date, $date_format)) eq 'ARRAY' and (@localtime = @$lt), 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}:\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 it would
    # mm/dd/yyyy - be impossible to figure out which one you are trying to use.
    }

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

sub paging {
# --------------------------------------------------------------
# Returns paging variables for the templates.
# 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, top_page => INTEGER }, and possibly dotdotdot => 1
# Inside the loop you have: <%page_num%> and <%is_current_page%>.
#
    my ($num_hits, $max_hits, $current_page, $disp_pages, $want_dotdotdot) = @_;

    $disp_pages ||= 20;
    $max_hits   ||= 25;
    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 wild_cards() {
    require GT::SQL::Condition;
    return $DB->table('StopLists')->select(GT::SQL::Condition->new(stl_email => LIKE => "%*%", stl_email => LIKE => "%?%", "OR"), ['stl_email'])->fetchall_arrayref;
}

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

sub _load_mime {
# --------------------------------------------------------------------
# Load the config file into a hash.
#
    my ($file, $name) = @_;
    $name ||= $file;
    require GT::MIMETypes;
    my $guess = GT::MIMETypes->guess_type($name);
    if (!$guess or $guess eq 'application/octet-stream') {
        if (-e $file) {
            $guess = -T _ ? 'text/plain' : 'application/octet-stream';
        }
        else {
            $guess = 'application/octet-stream';
        }
    }
    return $guess;
}

sub _load_global {
    my $name = shift;
    load_globals();
    return if (!exists $GLOBALS->{$name});

    my $value = $GLOBALS->{$name};
    $value = $value->() if ref $value eq 'CODE';
    return $value;
}

1;