# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::SQL::Table
#   CVS Info : 087,071,086,086,085 
#   $Id: Base.pm,v 1.72 2011/05/13 23:56:51 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description:
#   Base class for GT::SQL::Table and GT::SQL::Relation
#

package GT::SQL::Base;
# ===============================================================
use GT::Base;
use GT::AutoLoader;
use strict;
use vars qw($ERRORS $DEBUG @ISA $VERSION $ERROR_MESSAGE);
@ISA           = qw/GT::Base/;
$DEBUG         = 0;
$VERSION       = sprintf "%d.%03d", q$Revision: 1.72 $ =~ /(\d+)\.(\d+)/;
$ERROR_MESSAGE = 'GT::SQL';


# ============================================================================ #
#  TABLE ACCESSSOR                                                             #
# ============================================================================ #

sub table {
# -------------------------------------------------------------------
# Returns a table or relation argument. Called with array of table names:
#       my $relation = $db->table('Links', 'CatLinks', 'Category');
#       my $table    = $db->table('Links');
#
    my ($self, @tables) = @_;

# Make sure we have a driver, and a list of tables were specified.
    $self->{connect} or return $self->fatal(NODATABASE => 'table()');
    @tables          or return $self->fatal(BADARGS => 'Usage: $obj->table(@TABLES)');

    for (@tables) { # Tables aren't passed to table() prefixed, so prefix them all.
        $_ = $self->{connect}->{PREFIX} . $_;
    }
    my $cache_key = join("\0", @tables, $self->{connect}->{def_path});
    $cache_key = (@tables > 1 ? "RELATION\0" : "TABLE\0") . $cache_key;
    $self->{cache} and exists $GT::SQL::OBJ_CACHE{$cache_key} and return $GT::SQL::OBJ_CACHE{$cache_key};

    my $obj;
    if (@tables > 1) {
        $obj = $self->new_relation(@tables);
    }
    else {
        my $name = $self->{connect}->{def_path} . '/' . $tables[0] . '.def';
        (-e $name) or return $self->fatal(FILENOEXISTS => $name);
        $obj = $self->new_table($tables[0]);
    }
    # We don't need to worry about caching here - new_relation or new_table will add it to the cache.
    return $obj;
}

# ============================================================================ #
#  EDITOR ACCESSSOR                                                            #
# ============================================================================ #

$COMPILE{editor} = __LINE__ . <<'END_OF_SUB';
sub editor {
# -------------------------------------------------------------------
# Returns an editor object. Takes a table name as argument.
#   my $editor = $db->editor('Links')
#
    my $self       = shift;
    my $table_name = shift or return $self->fatal(BADARGS => 'Usage: $db->editor(\'tablename\')');

    $self->{connect}->{driver} or return $self->fatal(NODATABASE => 'editor()');

    my $table  = $self->table($table_name);

# Set the error package to reflect the editor
    $table->{_err_pkg}   = 'GT::SQL::Editor';
    $table->{_err_pkg}   = 'GT::SQL::Editor';

# Get an editor object
    require GT::SQL::Editor;
    $self->debug("CREATING GT::SQL::Editor OBJECT") if $self->{_debug} and $self->{_debug} > 2;
    return GT::SQL::Editor->new(
        debug   => $self->{_debug},
        table   => $table,
        connect => $self->{connect}
    );
}
END_OF_SUB

$COMPILE{prefix} = __LINE__ . <<'END_OF_SUB';
sub prefix {
    my $self = shift;
    return $self->{connect}->{PREFIX};
}
END_OF_SUB

sub new_table {
# -------------------------------------------------------------------
# Creates a table object for a single table.
#
    my ($self, $table) = @_;

    my $cache_key = "TABLE\0$table\0$self->{connect}->{def_path}";
    if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{$cache_key}) {
        $self->debug("Returning table object for $table from cache") if $self->{_debug} and $self->{_debug} >= 2;
        return $cached;
    }

    $self->debug("Creating new table object for $table") if $self->{_debug} and $self->{_debug} >= 2;
# Create a blank table object.
    my $table_obj = GT::SQL::Table->new(
        name     => $table,             # Already prefixed in schema
        connect  => $self->{connect},
        debug    => $self->{_debug},
        _err_pkg => 'GT::SQL::Table'
    );

# Create a new object if we are subclassed.
    my $subclass = $table_obj->subclass;
    my $name     = $table_obj->name;
    my $class    = $subclass->{table}->{$name} || 'GT::SQL::Table';
    if ($subclass and $subclass->{table}->{$name}) {
        no strict 'refs';
        $self->_load_module($class) or return;
        my $errors = defined ${$class . "::ERRORS"} ? ${$class . "::ERRORS"} : {};
        foreach (keys %$errors) {
            $ERRORS->{$_} = $errors->{$_};
        }
        use strict 'refs';
        $table_obj = $class->new(
            name     => $name,              # Already prefixed in schema
            connect  => $self->{connect},
            debug    => $self->{_debug},
            _err_pkg => 'GT::SQL::Table',
            _schema  => $table_obj->{schema}
        );
    }
    $self->debug("CREATING $class OBJECT") if $self->{_debug} and $self->{_debug} > 2;

    $GT::SQL::OBJ_CACHE{$cache_key} = $table_obj if $self->{connect}->{obj_cache};
    return $table_obj;
}

sub new_relation {
# -------------------------------------------------------------------
# Creates the table objects and relation object for multi-table tasks.
# Internal use. Call table instead.
#
    my ($self, @tables) = @_;
    my $href       = {};
    my $tables_ord = [];
    my $tables     = {};

    require GT::SQL::Relation;

    my $cache_key = join "\0", "RELATION", @tables, $self->{connect}->{def_path};
    if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{$cache_key}) {
        $self->debug("Returning relation object for @tables from cache") if $self->{_debug} and $self->{_debug} >= 2;
        return $cached;
    }

# Build our hash of prefixed table name to table object.
    foreach my $table (@tables) {
        $self->debug("CREATING GT::SQL::Table OBJECT") if $self->{_debug} and $self->{_debug} > 2;
        my $tmp  = $self->new_table($table);
        my $name = $tmp->name;
        push @$tables_ord, $name;
        $tables->{$name} = $tmp;
    }

# Get our driver, class name and key to look up subclasses (without prefixes).
    my $class        = 'GT::SQL::Relation';
    my $prefix       = $self->{connect}->{PREFIX};
    my $subclass_key = join "\0", map { s/^$prefix//; $_ } sort keys %{$tables};

# Look for any subclass to use, and load any error messages.
    no strict 'refs';

    foreach my $table (values %{$tables}) {
        my $subclass = $table->subclass;
        if ((!exists $self->{subclass} or $self->{subclass}) and exists $subclass->{relation}->{$prefix . $subclass_key}) {
            $class = $subclass->{relation}->{$prefix . $subclass_key};
            my $errors = defined ${$class . "::ERRORS"} ? ${$class . "::ERRORS"} : next;
            foreach (keys %$errors) {
                $ERRORS->{$_} = $errors->{$_};
            }
        }
    }
    use strict 'refs';

# Load our relation object.
    $self->debug("CREATING $class OBJECT") if $self->{_debug} and $self->{_debug} > 2;
    $self->_load_module($class) or return;

    my $rel = $class->new(
        tables     => $tables,
        debug      => $self->{_debug},
        connect    => $self->{connect},
        _err_pkg   => 'GT::SQL::Relation',
        tables_ord => $tables_ord
    );
    $GT::SQL::OBJ_CACHE{$cache_key} = $rel if ($self->{connect}->{obj_cache});

    return $rel;
}

# ============================================================================ #
#  CREATOR ACCESSSOR                                                           #
# ============================================================================ #
$COMPILE{creator} = __LINE__ . <<'END_OF_SUB';
sub creator {
# -------------------------------------------------------------------
# Returns a creator object. Takes a table name as argument.
#   my $creator = $db->creator('Links')
#
    my $self       = shift;
    my $table_name = shift or return $self->fatal(BADARGS => 'Usage: $db->creator(\'tablename\')');
    $self->{connect}->{driver} or return $self->fatal(NODATABASE => 'creator()');
    my $name = $self->{connect}->{PREFIX} . $table_name;

# Create either an empty schema or use an old one.
    $self->debug("Creating new GT::SQL::Table object '$table_name' to be used in Creator.") if $self->{_debug} and $self->{_debug} > 2;
    my $table = GT::SQL::Table->new(
        name     => $table_name,
        connect  => $self->{connect},
        debug    => $self->{_debug},
        _err_pkg => 'GT::SQL::Creator'
    );

# Return a creator object.
    require GT::SQL::Creator;
    $self->debug("CREATING GT::SQL::Creator OBJECT") if $self->{_debug} and $self->{_debug} > 2;
    return GT::SQL::Creator->new(
        table   => $table,
        debug   => $self->{_debug},
        connect => $self->{connect}
    );
}
END_OF_SUB

sub connect {
# -------------------------------------------------------------------
# Loads a driver object, and connects.
#
    my $self = shift;
    return 1 if $self->{driver};
    $self->{connect} or return $self->fatal('NOCONNECT');

    my $driver = uc $self->{connect}->{driver} || 'MYSQL';
    $self->{driver} = GT::SQL::Driver->load_driver(
        $driver,
        schema   => $self->{tables} || $self->{schema},
        name     => scalar $self->name,
        connect  => $self->{connect},
        debug    => $self->{_debug},
        _err_pkg => $self->{_err_pkg}
    ) or return $self->fatal(CANTLOAD => $driver, $GT::SQL::error);

    unless ($self->{driver}->connect) {
        delete $self->{driver};
        return;
    }

    return 1;
}

sub count {
# -------------------------------------------------------------------
# $obj->count;
# ------------
#   Returns the number of tuples handled
#   by this relation.
#
# $obj->count($condition);
# -------------------------
#   Returns the number of tuples that matches
#   that $condition.
#
    my $self = shift;
    my @cond;
    if (!ref $_[0] and @_ % 2 == 0 and defined $_[0]) {
        push @cond, {@_};
    }
    else {
        for (@_) {
            return $self->fatal(BADARGS => 'Arguments to count() must either be a hash, or one or more hash refs and/or GT::SQL::Condition objects')
                unless ref eq 'GT::SQL::Condition' or ref eq 'HASH';
            push @cond, $_;
        }
    }
    my $sel_opts = $self->{sel_opts};
    $self->{sel_opts} = [];
    my $sth = $self->select('COUNT(*)' => @cond ? GT::SQL::Condition->new(@cond) : ()) or return;
    $self->{sel_opts} = $sel_opts;
    return int $sth->fetchrow;
}

$COMPILE{total} = __LINE__ . <<'END_OF_SUB';
sub total {
# -------------------------------------------------------------------
#       total()
#           IN : none
#           OUT: total number of records in table
#
    shift->count
}
END_OF_SUB

$COMPILE{quote} = __LINE__ . <<'END_OF_SUB';
sub quote {
# -------------------------------------------------------------------
# $obj->quote($value);
# ---------------------
#   Returns the quoted representation of $value.
#
    return GT::SQL::Driver::quote(pop)
}
END_OF_SUB

$COMPILE{hits} = __LINE__ . <<'END_OF_SUB';
sub hits {
# -----------------------------------------------------------
#       hits()
#           IN : none
#           OUT: number of results in last search. (calls count(*) on
#                demand from hits() or toolbar())
#
    my $self = shift;
    if (! defined $self->{last_hits}) {
        $self->{last_hits} = (defined $self->{last_where} ? $self->count($self->{last_where}) : $self->count) || 0;
    }
    return $self->{last_hits};
}
END_OF_SUB

$COMPILE{_cgi_to_hash} = __LINE__ . <<'END_OF_SUB';
sub _cgi_to_hash {
# -------------------------------------------------------------------
# Internal Use
# $self->_cgi_to_hash($in);
# --------------------------
#   Creates a hash ref from a cgi object.
#
    my ($self, $cgi) = @_;
    defined $cgi and ref $cgi =~ /CGI/ or return $self->fatal(BADARGS => "'$cgi' is not a CGI object");

    my @keys = $cgi->param;
    my $result = {};
    for my $key (@keys) {
        my @values = $cgi->param($key);
        $result->{$key} = @values == 1 ? $values[0] : \@values;
    }
    return $result;
}
END_OF_SUB

$COMPILE{_get_search_opts} = __LINE__ . <<'END_OF_SUB';
sub _get_search_opts {
# -------------------------------------------------------------------
# Internal Use
# _get_search_opts($hash_ref);
# ----------------------------
#   Gets the search options based on the hash ref
#   passed in.
#
#   sb            => field_list     # Return results sorted by field list.
#   so            => [ASC|DESC]     # Sort order of results.
#   mh            => n              # Return n results maximum, default to 25.
#   nh            => n              # Return the n'th set of results, default to 1.
#   rs            => [col, col2]    # A list of columns you want returned
#
    my $self = shift;
    my $opt_r = shift;
    my $ret = {};
    $ret->{nh} = (defined $opt_r->{nh} and $opt_r->{nh} =~ /^(\d+)$/) ? $1 : 1;
    $ret->{mh} = (defined $opt_r->{mh} and $opt_r->{mh} =~ /^(-?\d+)$/) ? $1 : 25;
    $ret->{so} = (defined $opt_r->{so} and $opt_r->{so} =~ /^(ASC|DESC)$/i) ? $1 : '';
    $ret->{sb} = (defined $opt_r->{sb} and $opt_r->{sb} =~ /^([\w\s,.]+)$/)  ? $1 : '';

# You can pass in 'Col ASC, Col2 DESC' in {sb} so we need to remove sort order then.
    if ((lc $ret->{sb}) =~ /\s(?:asc|desc)/) {
        $ret->{so} = '';
    }
    if (defined $ret->{rs} and ref $ret->{rs} eq 'ARRAY') {
        my @valid;
        foreach my $col (@{$ret->{rs}}) {
            $col =~ /^([\w\s,]+)$/ and push @valid, $1;
        }
        $ret->{rs} = \@valid;
    }
    else {
        $ret->{rs} = (defined $opt_r->{rs} and $opt_r->{rs} =~ /^([\w\s,]+)$/) ? $1 : '';
    }
    return $ret;
}
END_OF_SUB

# Transitional support. build_query_cond _was_ a private method
$COMPILE{_build_query_cond} = __LINE__ . <<'END_OF_SUB';
sub _build_query_cond {
    my $self = shift;
    warn "obj->_build_query_cond() is deprecated; use obj->build_query_cond()" if $self->{_debug};
    $self->build_query_cond(@_)
}
END_OF_SUB

$COMPILE{build_query_cond} = __LINE__ . <<'END_OF_SUB';
sub build_query_cond {
# -------------------------------------------------------------------
# Builds a condition object based on form input.
#   field_name    => value      # Find all rows with field_name = value
#   field_name    => ">=?value" # Find all rows with field_name > or >= value.
#   field_name    => "<=?value" # Find all rows with field_name < or <= value.
#   field_name    => "!value"   # Find all rows with field_name != value.
#   field_name-opt => >=?|<=?|=|<>|LIKE|STARTS|ENDS
#                               # Find all rows with field_name (whichever) value.
#   field_name-gt => value      # Find all rows with field_name > value.
#   field_name-lt => value      # Find all rows with field_name < value.
#   field_name-ge => value      # Find all rows with field_name >= value.
#   field_name-le => value      # Find all rows with field_name <= value.
#   field_name-ne => value      # Find all rows with field_name != value.
#   keyword       => value      # Find all rows where any field_name = value
#   query         => value      # Find all rows using GT::SQL::Search module
#   ww            => 1      # 1 => use = comparision, 0/unspecified => use LIKE '%value%' comparision
#   ma            => 1      # 1 => OR match 0/unspecified => AND match
#
    my ($self, $opts, $c) = @_;

    my $cond = new GT::SQL::Condition;
    my ($cmp, $l);
    ($cmp, $l) = $opts->{ww} ? ('=', '') : ('LIKE', '%');
    $cond->boolean($opts->{ma} ? 'OR' : 'AND');
    my $ins = 0;

# First find the fields and find what we
# want to do with them.
    if (defined $opts->{query} and $opts->{query} =~ /\S/) {
        require GT::SQL::Search;
        my $search = GT::SQL::Search->load_search({
            %{$opts},
            db      => $self->{driver},
            table   => $self,
            debug   => $self->{debug},
            _debug  => $self->{_debug}
        });
        my $sth = $search->query();
        $self->{last_hits}  = $search->rows();
        $self->{rejected_keywords} = $search->{rejected_keywords};
        return $sth;
    }
    elsif (defined $opts->{keyword} and ($opts->{keyword} ne "") and ($opts->{keyword} ne '*')) {
        my $val    = $opts->{keyword};
        my $is_dig = $val =~ /^[+-]*\d+\.?\d*$/;

        foreach my $field (keys %$c) {
            next unless (index($c->{$field}->{type}, 'DATE') == -1);        # No DATE fields.
            next unless (index($c->{$field}->{type}, 'TIME') == -1);        # No TIME fields.
            next unless (index($c->{$field}->{type}, 'ENUM') == -1);        # No ENUM fields.
            next if (!$is_dig and (index($c->{$field}->{type}, 'INT') != -1));     # No ints if not an int.
            next if (!$is_dig and (index($c->{$field}->{type}, 'DECIMAL') != -1)); # No ints if not an int.
            next if (!$is_dig and (index($c->{$field}->{type}, 'FLOAT') != -1));   # No ints if not an int.

            $cond->add($field, $cmp, "$l$opts->{keyword}$l");
            $ins = 1;
        }
        $cond->bool('OR');
    }
    else {

# Go through each column and build condition.
        foreach my $field (keys %$c) {
            my $comp = $cmp;
            my $s    = $l;
            my $e    = $l;
            my @ins;

            if ($opts->{"$field-opt"}) {
                $comp = uc $opts->{"$field-opt"};

                $s = $e = '';
                if ( $comp eq 'LIKE' ) {
                    $e = $s = '%';
                }
                elsif ( $comp eq 'STARTS' ) {
                    $comp = 'LIKE';
                    $e = '%';
                }
                elsif ( $comp eq 'ENDS' ) {
                    $comp = 'LIKE';
                    $s = '%';
                }

            }
            else {
                if ($c->{$field}->{type} =~ /ENUM/i) {
                    $comp = '=';
                    $e = $s = '';
                }
            }

# Comp can only be: =, <, >, <=, >=, <>, LIKE, STARTS, ENDS
            $comp = '=' unless $comp =~ /^(=|<=?|>=?|<>|LIKE)$/i;

            if (exists $opts->{"$field-gt"} and ($opts->{"$field-gt"} ne "")) {
                push @ins, [$field, '>', $opts->{$field . "-gt"}];
            }
            if (exists $opts->{"$field-lt"} and ($opts->{"$field-lt"} ne "")) {
                push @ins, [$field, '<', $opts->{$field . "-lt"}];
            }
            if (exists $opts->{"$field-ge"} and ($opts->{"$field-ge"} ne "")) {
                push @ins, [$field, '>=', $opts->{$field . "-ge"}];
            }
            if (exists $opts->{"$field-le"} and ($opts->{"$field-le"} ne "")) {
                push @ins, [$field, '<=', $opts->{$field . "-le"}];
            }
            if (exists $opts->{"$field-ne"} and ($opts->{"$field-ne"} ne "")) {
                push @ins, [$field, '!=', $opts->{$field . "-ne"}];
            }

            if (exists $opts->{$field} and ($opts->{$field} ne "")) {
                if (ref($opts->{$field}) eq 'ARRAY' ) {
                    my $add = [];
                    for ( @{$opts->{$field}} ) {
                        next if !defined( $_ ) or !length( $_ ) or !/\S/;
                        push @$add, $_;
                    }
                    if ( @$add ) {
                        push @ins, [$field, 'IN', $add];
                    }
                }
                elsif ($opts->{$field} =~ /^(>=?|<=?|!)(.*)/) {
                    push @ins, [$field, ($1 eq '!') ? '<>' : $1, $2];
                }
                elsif ($opts->{$field} eq '+') {
                    push @ins, [$field, "<>", ''];
                }
                elsif ($opts->{$field} eq '-') {
                    push @ins, [$field, "=", ''];
                }
                elsif ($opts->{$field} eq '*') {
                    if ($opts->{"$field-opt"} and ($opts->{"$field-opt"} eq '<>')) {
                        push @ins, [$field, '=', ''];
                    }
                    else {
                        next;
                    }
                }
                else {
                    substr($opts->{$field}, 0, 1) = "" if substr($opts->{$field}, 0, 1) eq '\\';
                    push @ins, [$field, $comp, "$s$opts->{$field}$e"];
                }
            }

            if (@ins) {
                for (@ins) {
                    $cond->add($_);
                }
                $ins = 1;
            }

        }
    }

    return $ins ? $cond : '';
}
END_OF_SUB

sub _load_module {
# -------------------------------------------------------------------
# Loads a subclassed module.
#
    my ($self, $class) = @_;

    no strict 'refs';
    return 1 if (UNIVERSAL::can($class, 'new'));

    (my $pkg = $class) =~ s,::,/,g;
    my $ok  = 0;
    my @err = ();
    until ($ok) {
        local ($@, $SIG{__DIE__});
        eval { require "$pkg.pm" };
        if ($@) {
            push @err, $@;
            # In case the module had compile errors, %class:: will be defined, but not complete.
            undef %{$class . '::'} if %{$class . '::'};
        }
        else {
            $ok = 1;
            last;
        }
        my $pos = rindex($pkg, '/');
        last if $pos == -1;
        substr($pkg, $pos) = "";
    }
    unless ($ok and UNIVERSAL::can($class, 'new')) {
        return $self->fatal(BADSUBCLASS => $class, join ", ", @err);
    }
    return 1;
}

1;