# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::SQL::Table
#   Author  : Scott Beck
#   $Id: Table.pm,v 1.219 2002/08/12 02:00:34 jagerman Exp $
#
# Copyright (c) 2000 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description:
#   Class used to store and retrieve data from a table.
#

package GT::SQL::Table;
# ===============================================================
    use GT::SQL::Condition;
    use GT::SQL::Base;
    use GT::AutoLoader(NAME => '_AUTOLOAD');
    use GT::Base qw/:all/; # Imports $MOD_PERL $SPEEDY $PERSIST
    use strict;
    use vars qw/$DEBUG    $VERSION  @ISA  $AUTOLOAD
                $ERRORS   $ERROR_MESSAGE  $ERROR_PACKAGE
                %SCHEMAS  %TREE_CACHE     @COL_ATTRIBS
               /;

    @ISA           = qw/GT::SQL::Base/;
    $DEBUG         = 0;
    $VERSION       = sprintf "%d.%03d", q$Revision: 1.219 $ =~ /(\d+)\.(\d+)/;
    @COL_ATTRIBS   = qw/size type values default not_null pos regex weight form_display form_size form_type form_names form_values time_check/;
    $ERROR_PACKAGE = 'GT::SQL::Table';
    $ERROR_MESSAGE = 'GT::SQL';
    %SCHEMAS       = ();
    %TREE_CACHE    = ();

sub new {
# -------------------------------------------------------------
# new GT::SQL::Table (
#                      name     => table_name,
#                      debug   => debug level,
#                      _err_pkg => package name,
#                      driver   => driver name );
# -----------------------------------------------
#   Constructs (or returns if it already exists) a
#   new GT::SQL::Object with the parameters specified
#   above.
#
#
# new GT::SQL::Table ( $hashref );
# -------------------------------
#   Same thing, $hashref being a reference to a
#   hash which would be similar to what's above.
#
    my $this  = shift;
    my $class = ref $this || $this;
    my $self  = bless {}, $class;

    my $opts = $self->common_param(@_) or return $self->error ('BADARGS', 'FATAL', '$obj->new( HASH or HASH_REF or CGI ) only.');

    $self->{connect}  = $opts->{connect}    || {};
    $self->{_debug}   = $opts->{debug}      || $DEBUG;
    $self->{_err_pkg} = $opts->{_err_pkg}   || $ERROR_PACKAGE;
    $self->{_index}   = 0;
    $self->{_file}    = 0;

# Must have {connect} info first.
    $self->name($opts->{name});
    $self->{name}   ||= '';

# If the structure is in memory load it into the current object, otherwise load from file.
    my $file = $self->{connect}->{def_path} . '/' . $self->{name} . '.def';
    if (exists $SCHEMAS{$file}) {
        $self->{schema} = $SCHEMAS{$file};
    }
    elsif (-e $file) {
        $self->load_state ($file);
        $SCHEMAS{$file} = $self->{schema};
    }

# Some defaults for writting to
    $self->{schema}              ||= {};
    $self->{schema}->{index}     ||= {};
    $self->{schema}->{unique}    ||= {};
    $self->{schema}->{cols}      ||= {};
    $self->{schema}->{pk}        ||= [];
    $self->{schema}->{fk}        ||= {};
    $self->{schema}->{subclass}  ||= {};
    $self->{schema}->{ai}        ||= '';
    $self->{schema}->{fk_tables} ||= [];

    { # Check for weights or file columns and set _file and _index accordingly
        my ($found_file, $found_weight);
        my $c = $self->{schema}->{cols};
        for (keys %$c) {
            if (!$found_file and $c->{$_}->{form_type} and uc $c->{$_}->{form_type} eq 'FILE') {
                $self->_file_cols();
                $self->{_file} = ++$found_file;
            }
            if (!$found_weight and $c->{$_}->{weight}) {
                $self->{_index} = ++$found_weight;
            }
            last if $found_file and $found_weight;
        }
    }

    $self->debug ("Table '$self->{name}' object created.") if ($self->{_debug} > 2);
    return $self;
}

sub DESTROY {}

sub AUTOLOAD {
# -------------------------------------------------------------
# This method provides get methods for all the cols attributes.
# It returns a hash reference of the column names to the value
# of the attribute for that attribute.
#
    my $self = $_[0];
    my ($pkg, $what) = $AUTOLOAD =~ /^(.*)::([^:]+)$/;

# Otherwise we have auto generated functions for each of the
# column names.
    if (grep { $what eq $_ } @COL_ATTRIBS) {
        no strict 'refs';
        *{$AUTOLOAD} = sub {
            my $self = shift;
            my $h = {};
            foreach my $col (keys %{$self->{schema}->{cols}}) {
                if (exists $self->{schema}->{cols}->{$col}->{$what}) {
                    $h->{$col} = $self->{schema}->{cols}->{$col}->{$what};
                }
            }
            return wantarray ? %$h : $h;
        };
        goto &$AUTOLOAD;
    }

# Pass to the imported &_AUTOLOAD, which handles loading from %COMPILE
    goto &_AUTOLOAD;
}

sub connect {
# -------------------------------------------------------------------
# Fetches a driver object.
#
    return 1 if ($_[0]->{driver});
    my $self = shift;
    $self->{connect} or return $self->error('NOCONNECT', 'FATAL');

    my $driver = uc $self->{connect}->{driver} || 'MYSQL';
    my $pkg    = "GT::SQL::Driver::$driver";
    require "GT/SQL/Driver/$driver.pm";

    $self->{driver} = $pkg->new(
        schema   => $self->{schema},
        name     => $self->name,
        connect  => $self->{connect},
        debug    => $self->{_debug},
        _err_pkg => $self->{_err_pkg}
    ) or return $self->error(CANTLOAD => FATAL => $driver, $@);

    $self->{driver}->connect or return;

    return 1;
}

sub load_state {
# -----------------------------------------------------------
# $obj->load_state ();
# --------------------
#   restores Relation structure from def file.
#
    my $self = shift;
    my $name = $self->name;
    -e "$self->{connect}->{def_path}/$name.def" or return $self->error ("FILENOEXISTS", 'FATAL', "$self->{connect}->{def_path}/$name.def");
    local ($@, $!);
    $self->debug ("Loading state for " . $self->name) if ($self->{_debug} > 1);
    my $table = do "$self->{connect}->{def_path}/$name.def";
    ($@ or $!) and return $self->error ("BADCONFIG", 'FATAL', "$self->{connect}->{def_path}/$name.def", $@ ? "$@" : "$!");
    $self->{schema} = $table;
    $self->debug ("State loaded for " . $self->name) if ($self->{_debug} > 1);
    return 1;
}

# -------------------------------------------------------------------------------------- #
# SQL OPERATIONS                                                                         #
# -------------------------------------------------------------------------------------- #

sub add {
# -----------------------------------------------------------
#   add()
#       IN : hash/hash_ref/cgi/GT::CGI of col => val pairs to add.
#       OUT: ID number if auto_incremented table, or undef if failure
#
    my $self  = shift;
    my $input = $self->common_param(@_) or return $self->error ('BADARGS', 'FATAL', '$obj->insert( HASH or HASH_REF or CGI ) only.');
    my $table = $self->name or return $self->error ('NOTABLE', 'FATAL');

    my $c    = $self->{schema}->{cols};
    my $ai   = $self->{schema}->{ai};
    my $err  = 0;

# Clear errors.
    $self->{_error} = [];
    foreach my $col (keys %$c) {
        next if ($col eq $ai);
        if ($c->{$col}->{not_null} and (!defined $input->{$col} or $input->{$col} !~ /\S/)) {
            $self->error ('NOTNULL', 'WARN', $c->{$col}->{form_display} || $col);
            $err = 1;
        }
    }
    if ($err) {
        if (ref $self->{_error} and @{$self->{_error}}) {
            $GT::SQL::error = join "\n", @{$self->{_error}};
            return;
        }
    }
    my $sth  = $self->insert ($input);
    if ($sth) {
        if ($self->{schema}->{ai})  {   return $sth->insert_id; }
        else                        {   return 1 }
    }
    else                            {   return; }
}

sub insert {
# -----------------------------------------------------------
# $obj->insert (key1 => $value1, key2 => $value2);
# ------------------------------------------------
#   Key values pairs that correspond to the row you are
#   inserting.
#
# $obj->insert (\%row);
# ---------------------
#   A hash that contains key value pairs that corespond to
#   the row you are inserting.
#
    my $self  = shift;
    my $opts  = $self->common_param(@_) or return $self->error ('BADARGS', 'FATAL', '$obj->insert( HASH or HASH_REF or CGI ) only.');
    my $table = $self->name or return $self->error ('NOTABLE', 'FATAL');

# Connect to the database if we are not already connected
    $self->connect or return;

# Clear errors.
    $self->{_error} = [];

# Make sure we have some data.
    keys %$opts or return $self->error ("NOVALUES", 'WARN', "insert()");

# Copy the data and remove anything that doesn't make sense here.
    my $c     = $self->{schema}->{cols};
    my %set   = map { exists $opts->{$_} ? ($_ => $opts->{$_}) : () } keys %$c;

# Check for file uploads.
    my (%fset, %fcols);
    if ($self->{_file} and !$opts->{GT_SQL_SKIP_FILE} and %fcols = $self->_file_cols()) {
        require GT::SQL::File;
        %fset = GT::SQL::File->pre_file_actions( \%fcols, \%set, $opts ) or ( $GT::SQL::error and return );

    }

    my $tree;
    if ($self->{schema}->{tree}) {
        $tree = $self->tree;
        my $f = $tree->father_id_col;
        my $r = $tree->root_id_col;
        my $d = $tree->depth_col;
        if ($set{$f}) {
            my $pk = $self->{schema}->{pk}->[0];
            my ($root, $depth) = $self->select($r, $d, { $pk => $set{$f} })->fetchrow;
            $set{$r} = $root || $set{$f};
            $set{$d} = $depth + 1;
        }
        else {
            $set{$f} = $set{$r} = $set{$d} = 0; # A root post
        }
    }

    unless ($opts->{GT_SQL_SKIP_CHECK}) {
        $self->_check_insert(\%set) or return;
    }
    $self->{last_insert} = \%set;

# If we're indexing stuff, handle that.
    my $tmp_weight;
    if ($self->{_index} and !$opts->{GT_SQL_SKIP_INDEX} and $self->_weight_cols) {
        $tmp_weight = $self->_get_indexer->pre_add_record( $self->{last_insert} ) or return;
    }

# Query is executed inside to handle ai fields.
    my ($sql, $ph) = $self->{driver}->_insert_sql (\%set) or return;
    my $sth = $self->do_query($sql, $ph) or return;

# If we have files, let's save them.
    if ($self->{_file} and !$opts->{GT_SQL_SKIP_FILE}) {
        for ( keys %fcols ) { $set{$_} = $fset{$_}; $set{$_."_filename"} = $opts->{$_."_filename"} };
        if ( ( my @pk = $self->pk() ) == 1 and keys %fcols ) {
            my $key = ( $self->ai() ? $sth->insert_id : $set{$pk[0]} );
            require GT::SQL::File;
            my $tbl = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} }) or return;
            $tbl->add_file( \%set, $key ) or return;
        }
    }

# If we're indexing stuff, handle that.
    if ($self->{_index} and !$opts->{GT_SQL_SKIP_INDEX} and $self->_weight_cols) {
        $self->_get_indexer->post_add_record( $self->{last_insert}, $sth, $tmp_weight ) or return;
    }

# If a tree exists, insert any new entries required
    if ($self->{schema}->{tree}) {
        $tree->insert(insert_id => $sth->insert_id, data => \%set);
    }

    return $sth;
}

$COMPILE{insert_multiple} = __LINE__ . <<'END_OF_SUB';
sub insert_multiple {
# -----------------------------------------------------------
# $obj->insert_multiple(['key1', 'key2', 'key3'], [$value1_1, $value1_2, $value1_3], [$value2_1, $value2_2, $value2_3], ...);
# ------------------------------------------------
#   The first array ref is the columns, and all following
#   array refs are the values to be inserted.
#
#   This method doesn't mess around - it doesn't check to
#   make sure all the columns you entered exist, nor does
#   it do foreign key checks. Currently, it does not support
#   file columns or indexed columns.
#
#   Returned is the number of successful queries executed,
#   or undef if no queries were executed successfully.
#   Note that this may well be broken up into multiple
#   inserts if either a single query would be too long or
#   the database does not support multiple simultaneous
#   insertions.
#
    my ($self, $cols, @values) = @_;
    $cols or return $self->error('BADARGS', 'FATAL', '$obj->insert_multiple(ARRAY_REF, ARRAY_REF, ...) only');

    my $table = $self->name or return $self->error('NOTABLE', 'FATAL');

    $self->{schema}->{tree} and return $self->error(TREENOCANDO => FATAL => 'insert_multiple', $table);

# Connect to the database if we are not already connected
    $self->connect or return;

# Clear errors.
    $self->{_error} = [];

# Make sure we have some data, and the right number for each insert.
    @values or return $self->error("NOVALUES", 'WARN', "insert()");
    for my $val (@values) {
        if (@$val != @$cols) {
            return $self->error('BADMULTVALUES', 'FATAL', 'insert_multiple()');
        }
    }

    my $c = $self->{schema}->{cols};
    for (my $i = 0; $i < @$cols; $i++) {
        unless (exists $c->{$cols->[$i]}) {
            splice @$cols, $i, 1;
            for my $val (@values) {
                splice @$val, $i, 1;
            }
        }
    }

# Query is executed inside to handle ai fields.
    my @sql = $self->{driver}->_insert_multiple_sql($cols, \@values) or return;
    my $good;
    for my $sql_ref (@sql) {
        my ($sql, $ph) = @$sql_ref;
        $good++ if $self->do_query($sql, $ph);
    }
    return $good;
}
END_OF_SUB

$COMPILE{modify} = __LINE__ . <<'END_OF_SUB';
sub modify {
# -----------------------------------------------------------
#   modify()
#       IN : hash/hash_ref/cgi/GT::CGI of col => val pairs to change.
#       OUT: 1 on success, undef on failure.
#
    my $self  = shift;
    my $input = $self->common_param(@_) or return $self->error ('BADARGS', 'FATAL', '$obj->insert( HASH or HASH_REF or CGI ) only.');
    my $table = $self->name or return $self->error ('NOTABLE', 'FATAL');

# Connect to the database if we are not already connected
    $self->connect or return;

# Clear errors.
    $self->{_error} = [];

    my $c   = $self->{schema}->{cols};
    my $set = {};
    my $err = 0;
# Copy the data and remove anything that doesn't make sense here. Also, set
# errors for not null checks.

    foreach my $col (keys %$c) {
        $input->{$col."_del"} and ( $set->{$col."_del"} = $input->{$col."_del"} );
        $input->{$col."_filename"} and ( $set->{$col."_filename"} = $input->{$col."_filename"} );
        exists $input->{$col} ? ($set->{$col} = $input->{$col}) : next;
        next if ($col eq $self->{schema}->{ai});
        if (exists $c->{$col}->{not_null} and $c->{$col}->{not_null} and (!exists $input->{$col} or ($input->{$col} =~ /^\s*$/))) {
            if ($c->{$col}->{form_type} and uc $c->{$col}->{form_type} eq 'FILE') {
                my ( $pk ) = $self->pk();
                $input->{$col} = $self->file_info( $col, $input->{$pk} );
                next;
            }
            $self->error ('NOTNULL', 'WARN', $c->{$col}->{form_display} || $col);
            $err = 1;
        }
    }

# Remove primary keys from update clause and make sure we have a primary key.
    my $where;
    foreach my $key (@{$self->{schema}->{pk}}) {
        $where->{$key} = delete $set->{$key} if exists $set->{$key};
    }
    unless (keys %{$where} == @{$self->{schema}->{pk}}) {
        $self->error ("NOPKTOMOD", 'WARN');
        $err = 1;
    }

# Remove timestamps - no sense updating.
    $self->_check_timestamp ($where, $set) or ($err = 1);
    foreach my $col (keys %$c) {
        delete ($set->{$col}) if ($c->{$col}->{type} eq 'TIMESTAMP');
    }

# If we caught any errors, return.
    if ($err and ref $self->{_error} and @{$self->{_error}}) {
        $GT::SQL::error = join "\n", @{$self->{_error}};
        return;
    }

# Execute the update
    $self->update ($set, $where) or return;
    return 1;
}
END_OF_SUB

sub update {
# -----------------------------------------------------------
# $obj->update ($hash_ref, $condition, $opts);
# -------------------------------------
#   $condition is a Condition or a
#   hash reference.
#
# $obj->update ($hash_ref_1, $hash_ref_2, $opts);
# ----------------------------------------
#   Hash1 is what needs to be changed.
#   Hash2 is the condition.
#
    my $self = shift;
    my ($set, $where, $opts) = @_;
    ref $set eq 'HASH'  or return $self->error ('BADARGS', 'FATAL', '$obj->update(HASH_REF, CONDITION_OBJ or HASH_REF, HASH_REF)');
    keys %{$set}        or return $self->error ('BADARGS', 'FATAL', "update called with nothing to set!");
    $self->name         or return $self->error ('NOTABLE', 'FATAL');

# Connect to the database if we are not already connected
    $self->connect or return;

# Clear errors.
    $self->{_error} = [];

# Check to make sure the update is possible
    $opts  ||= {};
    $where ||= {}; # Update all.

# Check to see if we have files to update.
    my (%fset, %fcols);
    if ($self->{_file} and !$opts->{GT_SQL_SKIP_FILE} and %fcols = $self->_file_cols() ) {
        require GT::SQL::File;
        %fset = GT::SQL::File->pre_file_actions( \%fcols, $set, $opts ) or ( $GT::SQL::error and return );

        if ( not %$set and not %fset ) {
            return $self->error ('BADARGS', 'WARN', "update called with nothing to set!");
        }
    }

    my $where_cond  = $self->_build_cond ($where);

# If there is a tree, and the father_id is being updated, we need to call the appropriate tree method.
    my $tree_data;
    if ($self->{schema}->{tree}) {
        my $tree = $self->tree;
        if (exists $set->{$tree->father_id_col}) {
            #my @ids = $self->select($self->pk()->[0], $where_cond)->fetchall_list;
            $tree_data = $tree->pre_update(where => $where_cond, data => $set);
        }
    }

# Validate data.
    unless ($opts->{GT_SQL_SKIP_CHECK}) {
        $self->_check_update ($set, $where) or return;
    }
    my $set_cond    = $self->_build_set  ($set);
    $set_cond->boolean (',');

# If we are updating this tables primary key, then get the original
# value and save it for after the update.
    my $pk      = $self->{schema}->{pk};
    my $where_r = $where_cond->as_hash;
    my @update_pk;
    foreach (@$pk) {
        if (defined $set->{$_} and defined $where_r->{$_} and ($set->{$_} ne $where_r->{$_})) {
            push @update_pk, $_;
        }
    }

# Update the search index if required. Only do this if we are changing a weighted column.
    my $tmp_weights = {};
    my %wcols;
    if ($self->{_index} and ! $opts->{GT_SQL_SKIP_INDEX} and %wcols = $self->_weight_cols ) {
        foreach my $col (keys %wcols) {
            if ($wcols{$col} and exists $set->{$col}) {
                $tmp_weights = $self->_get_indexer->pre_update_record( $set_cond, $where_cond ) or return;
                last;
            }
        }
    }

# Generate the SQL.
    $self->{sel_opts} ||= [];
    my ($sql, $ph) = $self->{driver}->_update_sql ($set_cond, $where_cond);

# Save the where clause.
    $self->{last_where} = $where_cond;

# Execute the query.
    my $sth = $self->do_query($sql, $ph) or return;

# The query went successfully, so now if there is a tree, call the tree's update method
    if ($tree_data) {
        $self->tree->update($tree_data);
    }

# Update the foreign keys of other tables if this tables primary key changed.
    foreach my $key (@update_pk) {
        foreach my $table (@{$self->{schema}->{fk_tables}}) {
            my $new_me = $self->new_table ($table) or return $self->error ("FKNOTABLE", 'FATAL', $table, $GT::SQL::error);
            my $fk_hash = $new_me->{schema}->{fk}->{$self->name} or next;
            foreach my $my_col (keys %$fk_hash) {
                if ($fk_hash->{$my_col} eq $key) {
                    my $res = $new_me->update ( { $my_col => $set->{$key} }, { $my_col => $where_r->{$key} } );
                }
            }
        }
    }

# Update any file changes.
    if ( keys %fcols and $self->{_file} and !$opts->{GT_SQL_SKIP_FILE}) {
        require GT::SQL::File;
        my $File = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} });
        for ( keys %fcols ) {
                $set->{$_} = $fset{$_};
                $set->{$_."_del"} = $fset{$_."_del"};
        };
        $File->update_records( $set, $where_cond ) or return;
    }

# Update the search index if required.
    if ($self->{_index} and ! $opts->{GT_SQL_SKIP_INDEX} and %wcols = $self->_weight_cols ) {
        foreach my $col (keys %wcols) {
            if ($wcols{$col} and exists $set->{$col}) {
                $self->_get_indexer->post_update_record( $set_cond, $where_cond, $tmp_weights ) or return;
                last;
            }
        }
    }
    return $sth;
}

sub delete {
# -----------------------------------------------------------
# $obj->delete ($condition);
# --------------------------
#   $condition is a Condition or a
#   hash reference.
#
# $obj->delete ( $val );
# ----------------------
#   Deletes a single record based on the scalar value being the
#   primary key.
#
# $obj->delete ( [$val1, $val2] );
# --------------------------------
#   If you have a composite primary key, deletes a single record
#   based on the values being the primary keys.
#
# NOTE: use delete_all to delete everything
#
    my $self = shift;
    @_ > 0          or return $self->error ('BADARGS', 'FATAL', "You must call delete_all to delete all entries");
    $self->name     or return $self->error ('NOTABLE', 'FATAL');

# Connect to the database if we are not already connected
    $self->connect or return;
# Clear errors.
    $self->{_error} = [];

    my ($opt, $cond, $where, $do_select, %del, @rows);

# Determine what sort of delete to do.
    unless (@_ == 1) {
        for my $i (0 .. $#_) {
            $_ = $_[$i];
            /^abort$/    and do { $opt = splice(@_, $i, 1); last };
            /^cascade$/  and do { $opt = splice(@_, $i, 1); last };
            /^ignore$/   and do { $opt = splice(@_, $i, 1); last };
            /^cleanup$/  and do { $opt = splice(@_, $i, 1); last };
        }
    }

# Get the where clause we are going to use to do the delete. This can be
# either from a a scalar/array reference representing the primary key, or a
# condition/hash reference representing a where clause.
    if ( ((ref $_[0] eq 'ARRAY') or (not ref $_[0])) and (@_ == 1) ) {
        my @keys = @{$self->{schema}->{pk}};
        my @vals = ref $_[0] ? @{shift()} : shift();
        my $href = {};
        if (@keys != @vals) {
            return $self->error ('BADARGS', 'FATAL', "Your primary key is made of " . @keys . " elements, but you passed in " . @vals . " elements.");
        }
        while (@vals) {
            $href->{shift(@keys)} = shift(@vals);
        }
        (keys %{$href}) or return $self->error ('BADARGS', 'FATAL', '$obj->delete(CONDITION_OBJ or PRIMARY_KEY or [PRIMARY_KEY1, PRIMARY_KEY2])');
        $where = $self->_build_cond ($href);
    }
    else {
        ($where, $do_select) = _extract_where (@_);
    }

# Make sure $where is not empty.
    if (! $where->sql) {
        return $self->error ('BADARGS', 'FATAL', "Could not create a condition object out of arguments.");
    }

# Save the where clause.
    $self->{last_where} = $where;
    $opt              ||= 'cascade';

# Do a 'cascade' or 'abort' delete.
    if ($opt ne 'ignore' and $opt ne 'cleanup') {
        my $q;
# If they passed in a complex condition we select
        if ($do_select) {
            $q = $self->select ($where);
        }
# If the hash that was passed in does not contain the foreign keys we select
        elsif (not $self->_check_keys ($where)) {
            $q = $self->select ($where);
        }

        if ($q) { $self->_delete_select ($q, $opt)   or return }
        else    { $self->_delete_cond ($where, $opt) or return }
    }

# now handle the indexes if that's required
    my $tmp_weights = {};
    if ($self->{_index} and $self->_weight_cols) {
        $tmp_weights = $self->_get_indexer()->pre_delete_record( $where ) or return;
    }

# delete anything related to tables
    if ($self->{_file} and $self->_file_cols() ) {
        require GT::SQL::File;
        my $file = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} });
        $file->delete_records( $where );
    }

# For many to one fk relations
    my $rows;
    if ($opt eq 'cleanup') {
        defined($rows = $self->_delete_cleanup($where)) or return;
    }
    else {
# Get the SQL.
        my ($sql, $ph) = $self->{driver}->_delete_sql ($where);
        my $sth = $self->do_query ($sql, $ph) or return;
        $rows   = $sth->rows;
    }

    if ($self->{_index} and $self->_weight_cols) {
        $self->_get_indexer()->post_delete_record( $where, $tmp_weights ) or return;
    }

    defined $rows or return;
    return ($rows == 0) ? "0E0" : $rows;
}

$COMPILE{delete_all} = __LINE__ . <<'END_OF_SUB';
sub delete_all {
# -----------------------------------------------------------
# $obj->delete_all;
# -----------------
# Deletes all the records in the current table.
#
    my ($self, $opt, $done) = @_; # $done is used internally
    $opt ||= 'cascade';
    my $name = $self->name or return $self->error ('NOTABLE', 'FATAL');
    $done ||= { $name => 1 };

# Connect to the database if we are not already connected
    $self->connect or return;

# Clear errors.
    $self->{_error} = [];

# Do the cascading delete.
    for my $fktable (@{$self->fk_tables}) {
        next if $done->{$fktable}++;
        my $new_me = $self->new_table($fktable) or return $self->error("FKNOTABLE", 'FATAL', $fktable, $GT::SQL::error);
        if ($opt eq 'cascade') {
            $done->{$fktable}++;
            $new_me->delete_all($opt, $done) or return;
        }
        else {
            my $cnt = $new_me->count;
            if ($cnt) { return $self->error ("DEPENDENCY", 'WARN', $fktable) }
        }
    }
    my $tmp_weights = {};
    if ( $self->_weight_cols() ) { $tmp_weights = $self->_get_indexer()->pre_delete_all_records() or return };
    my ($sql, $ph) = $self->{driver}->_delete_sql();
    if ( $self->_weight_cols() ) { $self->_get_indexer()->pre_delete_all_records($tmp_weights) or return };

    return $self->do_query ($sql, $ph) or return;
}
END_OF_SUB

$COMPILE{query} = __LINE__ . <<'END_OF_SUB';
sub query {
# -------------------------------------------------------------------
# Just performs the query and returns a fetchall.
#
    return shift->_query(@_)->fetchall_arrayref;
}
END_OF_SUB

$COMPILE{query_sth} = __LINE__ . <<'END_OF_SUB';
sub query_sth {
# -------------------------------------------------------------------
# Just performs the query and returns an active sth.
#
    return shift->_query(@_);
}
END_OF_SUB

$COMPILE{_query} = __LINE__ . <<'END_OF_SUB';
sub _query {
# -------------------------------------------------------------------
# Parses the input, and runs a select based on input.
#
    my $self = shift;
    my $opts = $self->common_param(@_) or return $self->error ('BADARGS', 'FATAL', '$obj->insert( HASH or HASH_REF or CGI ) only.');
    $self->name or return $self->error ('NOTABLE', 'FATAL');
# Clear errors.
    $self->{_error} = [];

# Strip out values that are empty or blank (as query is generally
# derived from cgi input).
    my %input = map { $_ => $opts->{$_} } grep { defined $opts->{$_} and $opts->{$_} !~ /^\s*$/ } keys %$opts;
    $opts = \%input;

# If _build_query_cond returns a GT::SQL::Search object, then we are done.
    my $cond = $self->_build_query_cond ($opts, $self->{schema}->{cols});

    if ( ( ref $cond ) =~ /(?:DBI::st|::STH)$/i ) {
        return $cond;
    }

# If we have a callback, then we get all the results as a hash, send them
# to the callback, and then do the regular query on the remaining set.
    if (defined $opts->{callback} and (ref $opts->{callback} eq 'CODE')) {
        my $pk  = $self->{schema}->{pk}->[0];
        my $sth = $self->select ($cond, [$pk]) or return;
        my $res = $sth->fetchall_arrayref;
        my %res = map { $_->[0] => 1 } @$res;
        my $new_results = $opts->{callback}->($self, \%res);
        my $str = '(' . join (',', keys %$new_results) . ')';
        if ($str eq '()') {
            $cond = GT::SQL::Condition->new($pk, '=', undef); # No Results (just need an sth).
        }
        else {
            $cond = GT::SQL::Condition->new($pk, 'IN', \$str);
        }
    }

# Set the limit clause, defaults to 25, set to -1 for none.
    my $in = $self->_get_search_opts ($opts);
    my $offset   = ($in->{nh} - 1) * $in->{mh};
    $self->select_options ("ORDER BY $in->{sb} $in->{so}") if ($in->{sb});
    $self->select_options ("LIMIT $offset, $in->{mh}")     unless ($in->{mh} == -1);

# Now do the select.
    my @sel = ();
    if ($cond)                  { push @sel, $cond }
    if ($opts->{rs} and $cond)  { push @sel, $opts->{rs} }
    my $sth = $self->select (@sel) or return;

    return $sth;
}
END_OF_SUB

sub select_options {
# -----------------------------------------------------------
# $obj->select_options (@options);
# --------------------------------
#   @options should be a list of options you want append to your search.
#   Select options will be used for delete, and select.
#
    my $self = shift;
    push @{$self->{sel_opts}}, @_ if @_ > 0;
    wantarray ? @{$self->{sel_opts}} : $self->{sel_opts};
}

sub select {
# -----------------------------------------------------------
# $obj->select;
# -------------
#   returns all rows from that relation (no where condition).
#
# $obj->select ($condition, \@select_returns);
# --------------------------------------------
#   $condition is a Condition or a hash reference.
#
# $obj->select (\%columns, \@select_returns);
# -------------------------------------------
#   $col1 = $val1, $col2 = $val2
#
#   @select_returns is a list of the fields that you wish returned. If none are
#   specified all fields will be returned.
#
    my $self = shift;
    my $sel_opts = $self->{sel_opts} || [];
    $self->{sel_opts} = [];
    $self->name or return $self->error ('NOTABLE', 'FATAL');

# Connect to the database if we are not already connected
    $self->connect or return;

# Get the list of select fields.
    my (@fields);
    for (@_) {
        if (ref $_ eq 'ARRAY') { push @fields, @{$_} }
        elsif (not ref $_)     { push @fields, $_ }
    }
    @fields = grep defined && length, @fields;
# Extract the where clause and save it for future.
    my ($where, $do_select) = _extract_where (@_);
    $self->{last_where} = $where;
# Generate the SQL
    my ($sql, $ph) = $self->{driver}->_select_sql (\@fields, $where, $sel_opts);

# Execute the query.
#    print "Content-type: text/html\n\nSQL: $sql\n";
    my $sth = $self->do_query ($sql, $ph) or return;

# If we have LIMIT OFFSET, MAXHITS then we need to do a count
# unless we have an offset of 0 and no results.
# With no limit we don't need to do a count to get the total.
    my $found = 0;
    my $limit = join "", @$sel_opts;
    if ($limit =~ /\s*LIMIT\s*(\d+)\s*,?\s*(\d*)/) {
        if (($1 == 0) and $2) {
            my $rows = $sth->rows || 0;
            $rows < $2 ? ($self->{last_hits} = $rows) : ($self->{last_hits} = undef);
        }
        else {
            $self->{last_hits} = undef;
        }
        $found = 1;
    }
    if (! $found) {
        $self->{last_hits} = $sth->rows;
    }
    return $sth;
}

$COMPILE{get} = __LINE__ . <<'END_OF_SUB';
sub get {
# -----------------------------------------------------------
#       get()
#           IN : primary key and format options, and fields wanted.
#           OUT: array_ref/hash_ref on success, undef on failure.
#
    my $self = shift;

# Connect to the database if we are not already connected
    $self->connect or return;

    my (@keys, @pk, @sel, $cond, $method, $format, $cols);
    $self->name or return $self->error ('NOTABLE', 'FATAL');
    $cond = GT::SQL::Condition->new;

    if (@_ == 0) { return $self->error ('BADARGS', 'FATAL', '$obj->get(HASH or HASH_REF or CGI_OBJ)') }
    elsif (ref $_[0] eq 'HASH') {
        my $href = shift;
        for (keys %{$href}) {
            $cond->add ($_, '=', $href->{$_});
        }
    }
    else {
        @keys = ref $_[0] eq 'ARRAY' ? @{shift()} : (shift);
        @pk   = @{$self->{schema}->{pk}};
        while (@keys) {
            $cond->add (shift (@pk), '=', shift (@keys));
        }
    }

    $format = uc shift || 'HASH';
    $cols   = shift    || [];
    $method = $format eq 'ARRAY' ? 'fetchrow_arrayref' : 'fetchrow_hashref';
    my $sth = $self->select ($cond, $cols);
    if ($sth) {
        return $sth->$method();
    }
    else {
        return;
    }
}
END_OF_SUB

sub do_query {
# -----------------------------------------------------------
# $obj->do_query ($query, [ \@args ]);
# ------------------------
#   Performs SQL $query and returns a
#   Query object as the result of this query.
#
    my ($self, $query, $args) = @_;

    $self->connect or return;
    $query = $self unless (ref $self || $query);

# Show the query if debug is on.
    $self->debug ("Query: $query\n") if ($self->{_debug} > 1);

# Do the query.
    my $sth = $self->{driver}->prepare($query) or return;
    if ($args and ref $args eq 'ARRAY') {
        $sth->execute(@$args) or return;
    }
    else {
        $sth->execute or return;
    }
    $self->{sel_opts} = [];
    return $sth;
}

$COMPILE{do} = __LINE__ . <<'END_OF_SUB';
sub do {
    my $self = shift;
    return $self->do_query(@_);
}
END_OF_SUB

$COMPILE{reindex} = __LINE__ . <<'END_OF_SUB';
sub reindex {
# -----------------------------------------------------------
# $obj->reindex()
# -----------------------------------
#   Reindexes the database if required
#
    my $self = shift;
    my $opts = shift;

    $self->connect or return;
    my $Indexer        = $self->_get_indexer();
    $Indexer->reindex_all( $self, $opts );
}
END_OF_SUB

$COMPILE{indexing} = __LINE__ . <<'END_OF_SUB';
sub indexing {
# -----------------------------------------------------------
# $obj->indexing(0/1);
# --------------------
#    Enables/Disables indexing, spans life of object.
#
    @_ == 2 and ($_[0]->{_index} = $_[1]);
    return $_[0]->{_index};
}
END_OF_SUB

$COMPILE{reload} = __LINE__ . <<'END_OF_SUB';
sub reload {
# -----------------------------------------------------------
# $obj->reload
# Reload the schema file from disk.
#
    $_[0]->load_state;
}
END_OF_SUB

$COMPILE{prepare} = __LINE__ . <<'END_OF_SUB';
sub prepare {
# -----------------------------------------------------------
# Passes query straight through to dbh.
#
    my ($self, $query) = @_;
    $self->connect or return;
    return $self->{driver}->prepare($query);
}
END_OF_SUB

sub name {
# -----------------------------------------------------------
# $obj->name;
# -----------
#   Returns the name of the current table instance.
#
# $obj->name ($table_name);
# -------------------------
#   Sets the name for the table to create.
#
    my $self = shift;
    if (defined $_[0]) {
        my $name   = shift;
        my $prefix = $self->{connect}->{PREFIX};
        if (length $prefix) {
            unless ($name =~ /^$prefix/) {
                $name = $prefix . $name;
            }
        }
        unless ($name =~ /^(\w+)$/) {
            return $self->error ("BADNAME", 'FATAL', $name);
        }
        $self->{name} = $1;
    }
    return $self->{name};
}

# -------------------------------------------------------------------------------------- #
# ACCESSOR METHODS                                                                       #
# -------------------------------------------------------------------------------------- #

$COMPILE{cols} = __LINE__ . <<'END_OF_SUB';
sub cols {
# -----------------------------------------------------------
# $obj->cols;
# -----------
#   Returns the hash structure for this tables
#   cols.
#
# $obj->cols ($hash_ref);
# ---------------------------
#   Sets the relations columns as specified by $hash_ref.
#   the hash should look like { $col_name => { type => 'int' } }.
#
# $obj->cols ($array_ref);
# ------------------------
#   Just like $hash_ref, except an array ref. The array should look like:
#   [ $col_name => { type => 'int' } ]. The difference between this and
#   using a hash reference is that with the array ref pos will be automatically
#   calculated and set in each column definition. The following two lines passed
#   to cols() are equivelant and internally become the same thing:
#
#   { $col1 => { type => 'int', pos => 1 }, $col2 => { type => 'text', pos => 2 } }
#   [ $col1 => { type => 'int' }, $col2 => { type => 'text' } ]
#
# $obj->cols ($col1 => {
#                        type     => 'int',
#                        not_null => 1,
#             $col2 => { ... });
# -----------------------------------------
#   Sets the relations columns as specified via method
#   params.
#
    my $self = shift;
    if (@_ == 0) { return wantarray ? %{$self->{schema}->{cols}} : $self->{schema}->{cols} }
    elsif (@_== 1) {
            my $arg = shift;
            if (ref $arg eq 'HASH') {
                $self->{schema}->{cols} = $arg;
            }
            elsif (ref $arg eq 'ARRAY' and not @$arg % 2) {
                for (0 .. 0.5 * @$arg - 1) {
                    $arg->[2 * $_ + 1]->{pos} = $_ + 1;
                }
                $self->{schema}->{cols} = {@$arg};
            }
            else {
                return $self->error ('BADARGS', 'FATAL', '$obj->cols (HASH_REF or HASH)');
            }
    }
    elsif (not @_ % 2) { $self->{schema}->{cols} = {@_} }
    else { return $self->error('BADARGS', 'FATAL', '$obj->cols (HASH_REF or HASH)') }

    my $name = $self->{name};
    for (keys %{$self->{schema}->{cols}}) {
        ref ($self->{schema}->{cols}->{$_}) eq 'HASH'  or return $self->error ('BADARGS', 'FATAL', 'You must have a hash of hashes to specify your columns');
        exists ($self->{schema}->{cols}->{$_}->{type}) or return $self->error ('BADARGS', 'FATAL', "Error in table '$name' with column '$_': no type defined.");
        exists ($self->{schema}->{cols}->{$_}->{pos})  or return $self->error ('BADARGS', 'FATAL', "Error in table '$name' with column '$_': no position defined.");
    }
    return wantarray ? %{$self->{schema}->{cols}} : $self->{schema}->{cols};
}
END_OF_SUB

$COMPILE{pk} = __LINE__ . <<'END_OF_SUB';
sub pk {
# -----------------------------------------------------------
# $obj->pk;
# ---------
#   Returns an array in list context and an array
#   ref in scalar context. This array contain the
#   primary keys for the current table instance.
#
# $obj->pk ($array_ref);
# ----------------------
#   Sets relation primary key, $array_ref is the
#   reference to an array which looks like
#   ["FIELD1", ..., "FIELDN"]
#
# $obj->pk ($field1, $field2, ...);
# ---------------------------------
#   Sets relation primary key given the fields
#   which are in parameter.
#
    my $self = shift;
    my @pk;
    if (@_ == 0) { return wantarray ? @{$self->{schema}->{pk}} : $self->{schema}->{pk} }
    elsif (@_ == 1) {
        my $arg = shift;
        if (ref $arg eq 'ARRAY') {
            push @pk, @{$arg};
        }
        elsif (not ref $arg) {
            push @pk, $arg;
        }
        else {
            return $self->error ('BADARGS', 'FATAL', "Argument to pk must be an array ref or a list of scalars. You passed in $arg");
        }
    }
    else {
        foreach (@_) {
            if (not ref $_) {
                push @pk, @_;
            }
            else {
                return $self->error ('BADARGS', 'FATAL', "Argument to pk must be an array ref or a list of scalars. You passed in @_");
            }
        }
    }
    @{$self->{schema}->{pk}} = @pk;
    return wantarray ? @{$self->{schema}->{pk}} : $self->{schema}->{pk};
}
END_OF_SUB

$COMPILE{ai} = __LINE__ . <<'END_OF_SUB';
sub ai {
# -----------------------------------------------------------
# $obj->ai;
# ---------
#   Returns the auto incriment column for the current
#   table instance.
#
# $obj->ai ($column);
# -------------------
#   Sets the AUTO INCREMENT column.
#
    my ($self, $ai) = @_;
    $ai and ref ($ai) and return $self->error ('BADARGS', 'FATAL', "Argument to ai must not be a reference");
    $self->{schema}->{ai} = $ai if $ai;
    return $self->{schema}->{ai}
}
END_OF_SUB

$COMPILE{search_driver} = __LINE__ . <<'END_OF_SUB';
sub search_driver {
# -----------------------------------------------------------
# $obj->search_driver;
# ---------
#   Returns the search driver column for the current
#   table instance.
#
#   can be 'INTERNAL', 'MYSQL', 'NONINDEXED'
#
# $obj->search_driver ($column);
# -------------------
#   Sets the Searching Driver column.
#
    my ($self, $search_driver) = @_;
    $search_driver and ref ($search_driver) and return $self->error ('BADARGS', 'FATAL', "Argument to search_driver must not be a reference");
    $self->{schema}->{search_driver} = $search_driver if $search_driver;
    if ( not defined $self->{schema}->{search_driver} ) {
        my $indexer = $self->_get_indexer(1);
        ( ref $indexer ) =~ /::(\w+)::Indexer$/;
        $self->{schema}->{search_driver} = $1;
    }
    return $self->{schema}->{search_driver};
}
END_OF_SUB

$COMPILE{index} = __LINE__ . <<'END_OF_SUB';
sub index {
# -----------------------------------------------------------
# $obj->index;
# ------------
#   Returns a hash in list context and a hash ref
#   in scalar context. This hash contain the index
#   name as the keys and an array ref as the values.
#   The array ref contains the fields that are part of
#   the index that is the key.
#
# $obj->index ($index_name, $col1, ..., $coln);
# -------------------------------------------------
#   Sets an index called $index_name handling $col1,
#   ..., $coln.
#
# $obj->index (
#                  {
#                   $index1 => [field1, field2],
#                   $index2 => [field3, field4]
#                  }
#                 );
# ----------------------------------------------
#   Sets indexes for this table specified by the key
#   with the values as the fields.
#
    my $self = shift;
    if (@_ == 0) { return wantarray ? %{$self->{schema}->{index}} : $self->{schema}->{index} }
    if (@_ == 1) {
        my $arg = shift;
        if (ref $arg eq 'HASH') {
            $self->{schema}->{index} = $arg;
        }
        else {
            return $self->error ('BADARGS', 'FATAL', '$obj->index (INDEX_NAME, FIELD1, FIELD2 ...) or $obj->index (HASH_REF) or $obj->index')
        }
    }
    else {
        my $index_name = shift;
        $self->{schema}->{index}->{$index_name} = [];
        while (@_) {
            my $arg = shift || last;
            push @{$self->{schema}->{index}->{$index_name}}, (ref $arg eq 'ARRAY') ? $arg : [$arg];
        }
    }

    for (keys %{$self->{schema}->{index}}) {
        ref $self->{schema}->{index}->{$_} eq 'ARRAY' or return $self->error ('BADARGS', 'FATAL', "Index columns must be in the form of an array reference");
    }
    return wantarray ? %{$self->{schema}->{index}} : $self->{schema}->{index};
}
END_OF_SUB

sub subclass {
# -----------------------------------------------------------
# $obj->subclass;
# ---------------
#   Returns the subclass for the current table.
#   This subclass is what the objects are blessed
#   into. This makes it easy to subclass per table object.
#
# $obj->subclass ($subclass);
# ---------------------------
#   Sets the subclass. $subclass should be a hash
#   reference or a hash.
#
    my $self = shift;
    my $opt;
    if    (@_ == 0) { return wantarray ? %{$self->{schema}->{subclass}} : $self->{schema}->{subclass} }
    elsif (@_ == 1 and ref $_[0] eq 'HASH') { $opt = shift }
    elsif (defined ($_[0]) and not @_ % 2)  { $opt = {@_} }
    else  { return $self->error ('BADARGS', 'FATAL', '$obj->subclass (HASH or HASH_REF);') }

    foreach my $meth (qw/html relation table/) {
        next unless exists $opt->{$meth};
        if (ref $opt->{$meth} ne 'HASH') {
            return $self->error ('BADARGS', 'FATAL', 'The hash that is passed into subclass() must be a hash of hashes');
        }
        my $val = {};
        my $prefix = $self->{connect}->{PREFIX};
        for (keys %{$opt->{$meth}}) {
            my $v = $_;
            if (length $prefix) {
                unless (/^$prefix/) {
                    $v = $prefix . $v;
                }
            }
            $val->{$meth}->{$v} = $opt->{$meth}->{$_};
        }
        $self->{schema}->{subclass}->{$meth} = $val->{$meth};
    }
    return 1;
}

sub unique {
# -----------------------------------------------------------
# $obj->unique;
# -------------
#   Returns a hash in list context and a hash ref
#   in scalar context. This hash contains the unique
#   index names as the keys and array refs as the values.
#   The array refs contain the fields that are part of
#   the unique index.
#
# $obj->unique ($index_name, $col1, ..., $coln);
# ----------------------------------------------
#   Sets an unique index called $index_name handling $col1,
#   ..., $coln.
#
# $obj->unique (
#                  {
#                   $index1 => [field1, field2],
#                   $index2 => [field3, field4]
#                  }
#                 );
# ----------------------------------------------
#   Sets uniques for this table specified by the key
#   with the values as the fields.
#
    my $self = shift;
    if (@_ == 0) { return wantarray ? %{$self->{schema}->{unique}} : $self->{schema}->{unique} }
    if (@_ == 1) {
        my $arg = shift;
        if (ref $arg eq 'HASH') {
            $self->{schema}->{unique} = $arg;
        }
        else {
            return $self->error ('BADARGS', 'FATAL', '$obj->unique (INDEX_NAME, FIELD1, FIELD2 ...) or $obj->unique (HASH_REF) or $obj->unique')
        }
    }
    else {
        my $index_name = shift;
        $self->{schema}->{unique}->{$index_name} = [];
        while (@_) {
            my $arg = shift || last;
            push @{$self->{schema}->{unique}->{$index_name}}, (ref $arg eq 'ARRAY') ? $arg : [$arg];
        }
    }

    for (keys %{$self->{schema}->{unique}}) {
        ref $self->{schema}->{unique}->{$_} eq 'ARRAY' or return $self->error ('BADARGS', 'FATAL', "Index columns must be in the form of an array reference");
    }

    return wantarray ? %{$self->{schema}->{unique}} : $self->{schema}->{unique};
}

$COMPILE{fk} = __LINE__ . <<'END_OF_SUB';
sub fk {
# -----------------------------------------------------------
# $obj->fk;
# ---------
#   Returns a hash in list content and a hash ref in scalar
#   context. This hash ref contains the foreign table as the
#   key and a hash ref as the value. The has ref has keys as
#   the field in the current table that relates to fields in
#   the foreign table. The values are the fields in the foreign
#   table that the fields in this table relate to.
#
# $obj->fk (
#               {
#                 RELATION_NAME =>
#                 {
#                          SOURCE_FIELD_1 => TARGET_FIELD_2,
#                          ...
#                          SOURCE_FIELD_n => TARGET_FIELD_n
#                 }
#               });
# ----------------------------------------------------------
#   You can set all the relations for the tables this way.
#   sets the source and target schemas for the given relation
#   name. Source and target schemas shall have the same type !
#
# $obj->fk ( RELATION_NAME, { SOURCE_FIELD_1 => TARGET_FIELD });
# ------------------------------------------------------------------
#   Sets the foreign key relations for one relation.
#
#   this structure introduces a limitations: a table cannot
#   refer two schemas in the same target table, which should
#   really not be a problem.
#
    my $self = shift;
    my $prefix = $self->{connect}->{PREFIX};
    if (@_ == 0) { return wantarray ? %{$self->{schema}->{fk}} : $self->{schema}->{fk} }
    if (@_ == 1) {
        my $arg = shift;
        if (ref $arg eq 'HASH') {
            my $prev = $self->{schema}->{fk};
            foreach my $table (keys %{$arg}) {
                my $new_table = $table;
                if (length $prefix) {
                    $new_table = $prefix . $new_table unless $table =~ /^$prefix/;
                }
                $self->{schema}->{fk}->{$new_table} = $arg->{$table};
            }
        }
        else {
            return $self->{schema}->{fk}->{$arg};
        }
    }
    elsif (@_ == 2 and ref $_[1] eq 'HASH') {
        my $prev = $self->{schema}->{fk};
        my $table = shift;
        my $new_table = $table;
        if (length $prefix) {
            $new_table = $prefix . $new_table unless $table =~ /^$prefix/;
        }
        $self->{schema}->{fk}->{$new_table} = shift;
    }
    else {
        return $self->error ('BADARGS', 'FATAL', '$obj->fk (TABLE_NAME, HASH_REF or HASH_REF) or $obj->fk');
    }

# Make sure the arguments passed in were correct.
    foreach my $ftable (keys %{$self->{fk}}) {
        ref ($self->{schema}->{fk}->{$ftable}) eq 'HASH' or return $self->error ('BADARGS', 'FATAL', "fk must contain a hash of hashes");
    }

    $self->_update_fk_tables or return;
    return wantarray ? %{$self->{schema}->{fk}} : $self->{schema}->{fk};
}
END_OF_SUB

$COMPILE{fk_tables} = __LINE__ . <<'END_OF_SUB';
sub fk_tables {
# -----------------------------------------------------------
# Used to set the tables that reference this one.
#
    my $self = shift;
    if (@_ == 0) { return wantarray ? @{$self->{schema}->{fk_tables}} : $self->{schema}->{fk_tables} }
    elsif (@_ == 1) {
        my $arg = shift;
        if (ref $arg eq 'ARRAY') {
            $self->{schema}->{fk_tables} = \@{$arg};
        }
        else {
            @{$self->{schema}->{fk_tables}} = ($arg);
        }
    }
    else {
        @{$self->{schema}->{fk_tables}} = @_;
    }
    foreach (@{$self->{schema}->{fk_tables}}) {
        if (ref $_) {
            return $self->error ('BADARGS', 'FATAL', "Arguments to fk_table must be scalars");
        }
    }
    my $prefix = $self->{connect}->{PREFIX};
    foreach (@{$self->{schema}->{fk_tables}}) {
        if (length $prefix) {
            unless (/^$prefix/) {
                $_ = $prefix . $_;
            }
        }
    }
    return wantarray ? @{$self->{schema}->{fk_tables}} : $self->{schema}->{fk_tables};
}
END_OF_SUB

$COMPILE{tree} = __LINE__ . <<'END_OF_SUB';
sub tree {
# -----------------------------------------------------------
# An accessor for the GT::SQL::Tree object associated with
# this table. Creating/dropping a tree is done through the
# table editor. If no tree exists, you get undef and a warning
# occurs.
    my $self = shift;
    return $self->error(NOTREE => WARN => $self->name()) unless ($self->{schema}->{tree});
    if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{"TREE\0$self->{name}\0$self->{connect}->{def_path}"}) {
        $self->debug("Returning GT::SQL::Tree object for table $self->{name} from cache") if $self->{_debug};
        return $cached;
    }

    require GT::SQL::Tree;
    $self->debug("Creating new GT::SQL::Tree object for table " . $self->name()) if $self->{_debug};
    my $tree = GT::SQL::Tree->new({
        table => $self,
        debug => $self->{_debug}
    });

    if ($self->{connect}->{obj_cache}) {
        $GT::SQL::OBJ_CACHE{"TREE\0$self->{name}\0$self->{connect}->{def_path}"} = $tree;
    }

    return $tree;
}
END_OF_SUB

$COMPILE{check_schema} = __LINE__ . <<'END_OF_SUB';
sub check_schema {
# -----------------------------------------------------------
# Checks the current table schema for inconsistencies in the
# structure.
#
    my $self = shift;
    my %cols = %{$self->{schema}->{cols}};

# Go through each column and check them
    foreach my $col (keys %cols) {
# Make sure we have a position field.
        if (! exists $cols{$col}->{pos}) {
            $self->debug ("Trying to create a column that does not have a position field.") if ($self->{_debug});
            return $self->error ('NOPOS', 'FATAL', $col);
        }

# Primary key can not me a "text" or "blob" type and must be "not null".
        if ($self->_is_pk ($col)) {
            unless ($self->{schema}->{cols}->{$col}->{not_null}) {
                $self->debug ("Trying to use a primary key without making it not null. Adding $col to not null") if ($self->{_debug});
                $self->{schema}->{cols}->{$col}->{not_null} = 1;
            }
            if ($cols{$col}->{type} =~ /TEXT|BLOB/i) {
                return $self->error ("PKTEXT", 'FATAL', $col);
            }
        }

# Unique must be "not null" and can not be a "text" or "blob" type.
        for (keys %{$self->{schema}->{unique}}) {
            if (grep /^\Q$col\E$/, @{$self->{unique}->{$_}}) {
                unless ($self->{schema}->{cols}->{$col}->{not_null}) {
                    $self->debug ("unique key $col is not NOT_NULL. Adding to NOT_NULL") if ($self->{_debug});
                    $self->{schema}->{cols}->{$col}->{not_null} = 1;
                }
                if ($cols{$col}->{type} =~ /TEXT|BLOB/i) {
                    return $self->error ("UNIQTEXT", 'FATAL', $col);
                }
            }
        }

# Index must ne "not null" and can not be a "text" or "blob" type.
        for (keys %{$self->{schema}->{index}}) {
            if (grep /^\Q$col\E$/, @{$self->{schema}->{index}->{$_}}) {
                unless ($self->_is_not_null ($col)) {
                    $self->debug ("index key $col is not NOT_NULL. Adding to NOT_NULL") if ($self->{_debug});
                    $self->{schema}->{cols}->{$col}->{not_null} = 1;
                }
                if ($cols{$col}->{type} =~ /TEXT|BLOB/i) {
                    return $self->error ("INDXQTEXT", 'FATAL', $col) if ($self->{_debug});
                }
            }
        }

# Autoincriment must be an "INT" type and must be the only "PRIMARY KEY"
        $self->{schema}->{ai} ||= '';
        if ($col eq $self->{schema}->{ai}) {
            if ($cols{$col}->{type} !~ /INT/i) {
                return $self->error ("AINOTPK", 'FATAL', $col);
            }
            if (! $self->_is_pk ($col) or @{$self->{schema}->{pk}} > 1) {
                $self->debug ("AUTO_INCREMENT column $col specified but is not the primary key.") if ($self->{_debug});
                @{$self->{schema}->{pk}} = ($col);
            }
        }

# File columns must point to exisiting directories where we have write access!
        if ( $cols{$col}->{form_type} and uc $cols{$col}->{form_type} eq 'FILE'  ) {
            $cols{$col}->{file_save_in} or return $self->error( 'NOFILESAVEIN', 'FATAL', $col );
            ( -e $cols{$col}->{file_save_in} and -w $cols{$col}->{file_save_in} ) or
                return $self->error( 'NODIRPRIV', 'FATAL', $cols{$col}->{file_save_in});
        }

    }

# Circularity check
    $self->_circularity_check or return undef;

    return 1;
}
END_OF_SUB

$COMPILE{ordered_columns} = __LINE__ . <<'END_OF_SUB';
sub ordered_columns {
# -----------------------------------------------------------
# $obj->ordered_columns;
# ----------------------
#   Returns the current table columns ordered
#   in function of the "pos" type of a given
#   column.
#
#   The columns having no specified pos are
#   appended in lexicographical order at the
#   end of the result array.
#
    my $self   = shift;
    my @cols   = ();
    my @append = ();
    my $cols   = $self->{schema}->{cols};
    foreach my $col (sort {
        $cols->{$a}->{pos} &&  $cols->{$b}->{pos} ? $cols->{$a}->{pos} <=> $cols->{$b}->{pos} :
        $cols->{$a}->{pos} && !$cols->{$b}->{pos} ? -1 :
        $cols->{$b}->{pos} && !$cols->{$a}->{pos} ?  1 :
        ($a cmp $b)
    } keys %{$cols}) {
        push @cols, $col;
    }

    return @cols;
}
END_OF_SUB

$COMPILE{all_indexes} = __LINE__ . <<'END_OF_SUB';
sub all_indexes {
# -----------------------------------------------------------
# $obj->all_indexes;
# ------------------
#   Returns an array reference with all the array refs
#   from the indexes and the uniques.
#
    my $self = shift;
    my @keys = map { @$_ } values %{$self->unique}, values %{$self->index};
    return wantarray ? @keys : \@keys;
}
END_OF_SUB

$COMPILE{save_def} = __LINE__ . <<'END_OF_SUB';
sub save_def {
    shift->save_state (@_)
}
END_OF_SUB

$COMPILE{save_state} = __LINE__ . <<'END_OF_SUB';
sub save_state {
# -----------------------------------------------------------
# $obj->save_state;
# ----------------------------
#   saves table structure in $self->{connect}->{def_path}/table.def.
#
    my $self = shift;
    my $table = $self->name;
    my $fh = \do { local *FH; *FH };
    require GT::Dumper;

    $self->debug ("Saving state for $table") if ($self->{_debug} > 1);

    my $create = -e "$self->{connect}->{def_path}/$table.def" ? 0 : 1;
    open $fh, ">$self->{connect}->{def_path}/$table.def" or return $self->error(CANTOPEN => WARN => "$self->{connect}->{def_path}/$table.def", "$!");
    my $dump = GT::Dumper->dump (
                var  => '',
                data => $self->{schema},
                sort => 1,
                order => sub {
                    my ($keya, $keyb, $vala, $valb) = @_;
                    if (ref $vala eq 'HASH' and ref $valb eq 'HASH' and exists $vala->{pos} and exists $valb->{pos}) {
                        return $vala->{pos} <=> $valb->{pos};
                    }
                    else {
                        return $keya cmp $keyb;
                    }
                }
            );
    print $fh $dump;
    $self->debug ("State saved for $table") if ($self->{_debug} > 1);
    close $fh;

# Set so web and user can write to file.
    if ($create) {
        chmod (0666, "$self->{connect}->{def_path}/$table.def");
    }

# Save it to the cache.
    my $file = "$self->{connect}->{def_path}/$self->{name}.def";
    $SCHEMAS{$file} = $self->{schema};

    return 1;
}
END_OF_SUB

$COMPILE{file_info} = __LINE__ . <<'END_OF_SUB';
sub file_info {
# -------------------------------------------------------------------
# $obj->file('ColumnName', $primary_key);
# ------------------------------
#  Returns the file associated with the column
#
    my $self = shift;
    require GT::SQL::File;
    my $File = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} });
    return $File->file_info(@_);
}
END_OF_SUB

$COMPILE{file_rescan} = __LINE__ . <<'END_OF_SUB';
sub file_rescan {
# -------------------------------------------------------------------
    my $self = shift;
    require GT::SQL::File;
    my $File = GT::SQL::File->new({ parent_table => $self, connect => $self->{connect} });
    return $File->rescan();
}
END_OF_SUB

sub check_values {
# -------------------------------------------------------------------
#   Checks to see that the values for an insert are legal to
#   be inserted. Returns false on error true on success
#
    my ($self, $set) = @_;

# Check to ensure the values are valid
    my %cols    = %{$self->{schema}->{cols}};
    my $ai      = $self->{schema}->{ai};
    for my $col (keys %{$set}) {
        next if ($ai and $ai eq $col);
        if (ref $set->{$col} eq 'ARRAY') {
            require GT::SQL::Display::HTML;
            $set->{$col} = join ($GT::SQL::Display::HTML::INPUT_SEPARATOR, sort @{$set->{$col}});
        }
        $self->_check_value ($col, $cols{$col}, $set->{$col});
    }
    if (ref $self->{_error} and @{$self->{_error}}) {
        $GT::SQL::error = join "\n", @{$self->{_error}};
        return;
    }
    return 1;
}

# -------------------------------------------------------------------------------------- #
# PRIVATE FUNCTIONS                                                                      #
# -------------------------------------------------------------------------------------- #
$COMPILE{_update_fk_tables} = __LINE__ . <<'END_OF_SUB';
sub _update_fk_tables {
# -------------------------------------------------------------------
#   Updates all the tables fields that
#   this tables is referenced by.
#
    my $self = shift;
    foreach my $table (keys %{$self->{schema}->{fk}}) {
        my $new_me = ($table eq $self->{name}) ? $self : ($self->new_table($table) or return $self->error ("FKNOTABLE", 'FATAL', $table, $GT::SQL::error));
        $new_me->_add_fk_table($self->{name});
        $new_me->save_state();
    }
    return 1;
}
END_OF_SUB

$COMPILE{_add_fk_table} = __LINE__ . <<'END_OF_SUB';
sub _add_fk_table {
# -------------------------------------------------------------------
# Takes a foreign table name. The foreign table is added if it
# doesn't already exist in $self's fk_tables schema. Any duplicates
# are removed. This is to prevent the same table appearing several
# times in fk_tables. You still need to ->save_state() after calling
# this.
    my ($self, $add) = @_;
    my %have;
    $self->{schema}->{fk_tables} = [grep (!$have{$_}++, @{$self->{schema}->{fk_tables}}, $add)];
}
END_OF_SUB

$COMPILE{_circularity_check} = __LINE__ . <<'END_OF_SUB';
sub _circularity_check {
# -------------------------------------------------------------------
#  This function loops thru all the tables in the current
#  databases. If a circular reference is detected, then a
#  warning is printed and FALSE is returned. If no circular
#  references are detected, TRUE is returned.
#
    my $self = shift;
    my (%cols, @tables, %tables);

    return 1 unless keys %{$self->{schema}->{fk}}; # If there are no foreign keys, there isn't much to do.

    my $name = $self->name;

    @tables = $name;
    $tables{$name}++;

    for (my $i = 0; $i < @tables; $i++) {
        return $self->error(CIRCULARLIMIT => 'FATAL') if $i >= 100;

        my $table = $tables[$i];
        my $new = ($table eq $name) ? $self : $self->new_table($table) or return $self->error(FKNOTABLE => FATAL => $table, $GT::SQL::error);
        for my $table_name (keys %{$new->{schema}->{fk}}) {
            my %this; # Allows for multiple fk's from the same table to the same key
            for my $column (keys %{$new->{schema}->{fk}->{$table_name}}) {
                my $tc = "$table: $table_name.$new->{schema}->{fk}->{$table_name}->{$column}";
                $self->debug("Found foreign key in $tc") if $self->{_debug};
                if (not $this{$tc}++ and $cols{$tc}++) {
                    $self->debug("$tc was already found!") if $self->{_debug};
                    return $self->error(CIRCULAR => WARN => $tc);
                }
                splice @tables, $i + 1, 0, $table_name unless $tables{$table_name}++;
            }
        }
    }

    return 1;
}
END_OF_SUB


$COMPILE{_check_timestamp} = __LINE__ . <<'END_OF_SUB';
sub _check_timestamp {
# -------------------------------------------------------------------
# Won't modify a record if the passed in timestamp is older then
# what's in the database.
#
    my ($self, $keys, $set) = @_;

# first check to see if we even need to look up the orig timestamp.
    my $auto = $self->time_check;
    return 1 unless ($auto);
    my $found = 0;
    foreach (keys %$auto) {
        exists $set->{$_} and ($found = 1);   # should only be one timestamp.
    }
    return 1 unless ($found);

# if we got here, then we do a search on the record and compare timestamp.
    my $pk = $self->{schema}->{pk};
    my $cond = GT::SQL::Condition->new;
    my @res;
    foreach my $key (@$pk) {
        $cond->add ($key, "=", $keys->{$key});
    }
    foreach my $tmstmp (keys %$auto) {
        push @res, $tmstmp;
        $cond->add ($tmstmp, ">", $set->{$tmstmp});
        delete $set->{$tmstmp};
    }
    my $sth = $self->select ($cond, \@res) or return;
    if ($sth->fetchrow_arrayref) {
        return $self->error ('ALREADYCHANGED', 'WARN');
    }
    else {
        return 1;
    }
}
END_OF_SUB

sub _check_insert {
# -------------------------------------------------------------------
#   Check to make sure an insert is properly set up.
#
    my ($self, $set, $cond) = @_;
    my @indexes;
    my %indx_hash = $self->unique;
    push @indexes, values %indx_hash if (keys %indx_hash);

# Add the primary key to the list of uniques
    if (@{$self->{schema}->{pk}} and ! $self->{schema}->{ai}) {
        push @indexes, $self->{schema}->{pk};
    }

# Check to make sure that not_null columns without defaults have been specified
    while (my ($c, $col) = each %{$self->{schema}->{cols}}) {
        my $default = $col->{default};
        if ((not defined $set->{$c} or $set->{$c} eq '') and
            ($col->{not_null}) and # Only check for not_null columns
            (not $self->{schema}->{ai} or $c ne $self->{schema}->{ai}) and # But not the auto-increment field
            (not defined $default or $default eq '')) { # And only when there isn't a default
            $self->error(NOTNULL => WARN => $col->{form_display} || $c);
        }
    }
            
# Check that the unique columns are really unique.
    my $check = {};
    INDEX: foreach my $index (@indexes) {
        my $check = {};
        COL: foreach my $col (@$index) {
            next INDEX if ($col eq $self->{schema}->{ai});
            $check->{$col} = $set->{$col};
        }
        my $rows = $self->count($check);
        if ($rows) {
            $self->error('UNIQUE', 'WARN', join(",", map $self->{schema}->{cols}->{$_}->{form_display} || $_, keys %$check), join(",", values %$check));
        }
    }
# Check the values to make sure they are ok.
    $self->check_values($set);

# Join the list of errors.
    my @errors = (ref($self->{_error}) and @{$self->{_error}}) ? @{$self->{_error}} : ();
    if (@errors) {
        $GT::SQL::error = join "\n", @errors;
        return;
    }
    return 1;
}

sub _check_update {
# -------------------------------------------------------------------
#   Checks to see if any of the set options
#   are unique. If they are does a select
#   on the table. If the condiftion tests
#   true returns undef. The error will be set in
#   the package error variable.
#
    my ($self, $set, $cond) = @_;

# Turn off warning here (too much work to remove unitilized values from
# returned data).
    local $^W = 0;

# Ensure that columns that are NOT NULL have not been specified as null
    my %cols = %{$self->{schema}->{cols}};
    for my $col (keys %{$set}) {
        if (ref $set->{$col} eq 'ARRAY') {
            require GT::SQL::Display::HTML;
            $set->{$col} = join ($GT::SQL::Display::HTML::INPUT_SEPARATOR, sort @{$set->{$col}});
        }
        $self->_check_value ($col, $cols{$col}, $set->{$col}) or return;
    }
    my %indx_hash = $self->unique;
    my @indexes   = values %indx_hash;

# Add the primary key to the list of uniques
    my $pk = $self->{schema}->{pk};
    $pk    = ref $pk ? $pk : [$pk];
    push @indexes, $pk unless $self->{schema}->{ai};

# If there are no uniques, then return previous errors, or return 1.
    if (! @indexes) {
        if (ref $self->{_error} and @{$self->{_error}}) {
            $GT::SQL::error = join "\n", @{$self->{_error}};
            return;
        }
        else {
            return 1;
        }
    }
    my @marked  = ();

# Only request what has changed plus the primary key and any uniques
    my %changes = ();
    for (keys %{$set}) { $changes{$_} = 1 }
    for (@{$pk})       { $changes{$_} = 1 }
    for my $index (@indexes) {
        for (@{$index}) {
            $changes{$_} = 1;
        }
    }

# Fetch records to make sure we don't break a unique clause.
    my $sth = $self->select ([keys %changes], $cond) or return;
    RECORD: while (my $rec = $sth->fetchrow_hashref) {

# Go through all the indexes for this table
        for my $i (0 .. $#indexes) {

# A hash to build the count query out of
            my $count_check = {};

# If the record is different than the one in the database
            my $match = 0;
            for (@{$indexes[$i]}) {
                if (defined $set->{$_} and ($set->{$_} ne $rec->{$_})) {
                    $match = 1;
                }
                $count_check->{$_} = $set->{$_};
            }

# It was not different so we continue to the next set of uniques
            $match or next;

# It was different so we need to make a count select to see if it is possible
# to do this insert
            if ($self->count ($count_check)) {

# the count returned tru so there was a duplicate record
                $self->error ("UNIQUE", 'WARN', join (',' =>  map { $set->{$_} } @{$indexes[$i]}), join (',' =>  @{$indexes[$i]}));
                last RECORD;
            }
            else {
# The count returned false so there was not a duplicate record
# so if the record is already marked we return false
                if ($marked[$i]) {
                    $self->error ("UNIQUE", 'WARN', join (',' =>  map { $set->{$_} } @{$indexes[$i]}), join (',' =>  @{$indexes[$i]}));
                    last RECORD;
                }
                else {
# else we mark the record.
                    $marked[$i] = 1;
                }
            }
        }
    }

# Everything should have went fine so return true the record is
# insertable.
    if (ref $self->{_error} and @{$self->{_error}}) {
        $GT::SQL::error = join "\n", @{$self->{_error}};
        return;
    }
    else {
        return 1;
    }
}

sub _check_value {
# -------------------------------------------------------------------
#   Checks to see if a value is valid.
#
    my ($self, $name, $column, $value) = @_;

    my ($regex);
    if ($column->{not_null} and not defined $value) {
        $self->error ('ILLEGALVAL', 'WARN', $column->{form_display} || $name, $value);
    }
    if (($column->{type} eq 'ENUM') and $value) {
        foreach (@{$column->{values}}) { $regex .= quotemeta($_) . "|"; }
        chop $regex;
        $regex = '^' . $regex . '$';
    }
    else {
        $regex = $column->{regex} || '';
    }

    if ($regex) {
        if (! ref $value) {
            eval {
                if ($value !~ /$regex/) {
                    $self->error ("ILLEGALVAL", 'WARN', $column->{form_display} || $name, $value);
                }
                1;
            } or $self->error ("REGEXFAIL", 'WARN', $regex);
        }
    }
    if (ref $self->{_error} and @{$self->{_error}}) {
        $GT::SQL::error = join "\n", @{$self->{_error}};
        return;
    }
    return 1;
}

sub _extract_where {
# -------------------------------------------------------------------
#   Takes the users input and extracts the
#   hash refs or condition clause. Creates
#   a Condition object and returns it.
#   Returns where the query was a hash or not
#   as well.
#
    my @args = @_;
    my $cond = GT::SQL::Condition->new;
    my $do_select = 0;
    for (@args) {
        if (ref $_ eq "HASH") {
            for my $key (keys %{$_}) {
                if (ref $_->{$key} eq 'ARRAY') {
                    $cond->add($key => 'IN' => $_->{$key});
                }
                elsif (defined $_->{$key}) {
                    $cond->add($key => '=' => $_->{$key});
                }
                else {
                    $cond->add($key => IS => \'NULL');
                }
            }
        }
        elsif (ref $_ eq 'GT::SQL::Condition') {
            $do_select = 1;
            $cond->add ($_);
        }
    }
    return ($cond, $do_select);
}

sub _build_cond {
# -------------------------------------------------------------------
# this subroutine is done to build conditions
# which may not be a Condition
# for selects and deletes.
#
    my $self = shift;
    my $cond = shift;

    my $cols = $self->{schema}->{cols};

    if (ref $cond eq 'GT::SQL::Condition') {
        return $cond;
    }
    elsif (ref $cond eq 'HASH') {
        my $tmp = new GT::SQL::Condition;
        foreach my $key (keys %{$cond}) {
            next unless exists $cols->{$key};
            if (ref $cond->{$key} eq 'ARRAY') {
                $tmp->add($key => IN => $cond->{$key});
            }
            elsif (defined $cond->{$key}) {
                $tmp->add($key => '=' => $cond->{$key});
            }
            else {
                $tmp->add($key => 'IS' => \'NULL');
            }
        }
        return $tmp;
    }
    elsif (ref $cond eq 'ARRAY') {
        my $tmp = new GT::SQL::Condition (@{$cond});
        return $tmp;
    }
    $self->error ('BADARGS', 'FATAL', "_build_cond takes only a condition, array ref, or hash ref. Not: '$cond'");
}

sub _build_set {
# -------------------------------------------------------------------
# Internal use
# Builds the set options for the query.
# May need to be changed later.
#
    my $self = shift;
    my $cond = shift;

    my $cols = $self->{schema}->{cols};

    if (ref $cond eq 'GT::SQL::Condition') {
        return $cond;
    }
    elsif (ref $cond eq 'HASH') {
        my $tmp = new GT::SQL::Condition;
        foreach my $key (keys %{$cond}) {
            $tmp->add ($key, "=", $cond->{$key}) if exists $cols->{$key};
        }
        return $tmp;
    }
    elsif (ref $cond eq 'ARRAY') {
        my $tmp = new GT::SQL::Condition (@{$cond});
        return $tmp;
    }
    $self->error ('BADARGS', 'FATAL', "_build_cond takes only a condition, array ref, or hash ref. Not: '$cond'");
}

$COMPILE{_check_keys} = __LINE__ . <<'END_OF_SUB';
sub _check_keys {
# -------------------------------------------------------------------
#   Checks to see if the arguments passed into
#   delete contains the externally linked columns
#
    my ($self, $where) = @_;
    (ref $where) or return $self->error ('BADARGS', 'FATAL', '_check_keys');
    my $cond = (ref $where eq 'HASH') ? $where : $where->as_hash;
    for ($self->fk_tables) {
        my $new_schema = $self->new_table ($_) or return $self->error ("FKNOTABLE", 'FATAL', $_, $GT::SQL::error);
        my %hash = $new_schema->fk;
        my $name = $self->name;

        for my $fkey (values %{$hash{$name}}) {
            return unless exists $cond->{$fkey};
        }
    }
    return 1;
}
END_OF_SUB

$COMPILE{_do_opt} = __LINE__ . <<'END_OF_SUB';
sub _do_opt {
# -------------------------------------------------------------------
#   Does a select or delete based on the option
#
    my ($self, $opt, $sel_hashr, $table_name) = @_;
    my $new_me = $self->new_table ($table_name) or return $self->error ("FKNOTABLE", 'FATAL', $table_name, $GT::SQL::error);
    if ($opt eq 'cascade') {
        my $cond;
        if ($self->{schema}->{tree} and keys %$sel_hashr > 1 and $self->tree->{tree}->name() eq $new_me->name()) {
            $cond = [];
            for (keys %$sel_hashr) {
                push @$cond, GT::SQL::Condition->new($_ => '=' => $sel_hashr->{$_});
            }
        }
        else {
            $cond = $sel_hashr;
        }
        if (ref $cond eq 'ARRAY') {
            for (@$cond) {
                $new_me->delete($_) or return;
            }
        }
        else {
            $new_me->delete ($cond) or return;
        }
    }
    else {
        my $cnt = $new_me->count ($sel_hashr);
        if ($cnt) { return $self->error ("DEPENDENCY", 'WARN', $table_name) }
    }
    return 1;
}
END_OF_SUB

$COMPILE{_delete_cond} = __LINE__ . <<'END_OF_SUB';
sub _delete_cond {
# -------------------------------------------------------------------
#   Performs the delete based on a condition object
#
    my ($self, $where, $opt) = @_;
    my $cond = ref $where eq 'HASH' ? $where : $where->as_hash;
    for my $fktable (@{$self->fk_tables}) {
        my $new_schema  = $self->new_table($fktable) or return $self->error("FKNOTABLE", 'FATAL', $fktable, $GT::SQL::error);
        my %fk          = $new_schema->fk;
        my $fk_href     = $fk{$self->name};
        my $sel_hashr   = {};
        for (keys %$fk_href) {
            if (exists $cond->{$fk_href->{$_}}) {
                $sel_hashr->{$_} = $cond->{$fk_href->{$_}};
            }
        }
        $self->_do_opt ($opt, $sel_hashr, $fktable) or return;
    }
    return 1;
}
END_OF_SUB

$COMPILE{_delete_select} = __LINE__ . <<'END_OF_SUB';
sub _delete_select {
# -------------------------------------------------------------------
#   Performs the delete based on the cascade
#   option
#
    my ($self, $q, $opt) = @_;
    my $fk_del;
    my $data = $q->fetchall_hashref;
    for my $fktable (@{$self->fk_tables}) {
        my $new_schema = $self->new_table($fktable) or return $self->error("FKNOTABLE", 'FATAL', $fktable, $GT::SQL::error);
        my %fk         = $new_schema->fk;
        my $fk_href    = $fk{$self->name};
        my $sel_hashr  = {};
        for my $row (@$data) {
            for my $fk (keys %$fk_href) {
                push @{$sel_hashr->{$fk}}, $row->{$fk_href->{$fk}};
            }
        }
        $self->_do_opt($opt, $sel_hashr, $fktable) or return if keys %$sel_hashr;
    }

    return 1;
}
END_OF_SUB

$COMPILE{_delete_cleanup} = __LINE__ . <<'END_OF_SUB';
sub _delete_cleanup {
# -------------------------------------------------------------------
# Performs the delete based on one to many relationship.
#
    my ($self, $where) = @_;
    my $ret;

# Get the SQL.
    my $sth = $self->select($where);

    my $q = $sth->fetchall_arrayref();
    ((ref($q) ne 'ARRAY') or (@{$q} == 0)) and return 0;

    my ($sql, $ph) = $self->{driver}->_delete_sql ($where);
    $sth     = $self->do_query ($sql, $ph) or return;
    my $rows = $sth->rows;

    my $name  = $self->name;
    for my $fk_table ($self->fk_tables) {

        my $new_schema = $self->new_table ($fk_table) or return $self->error ("FKNOTABLE", 'FATAL', $fk_table, $GT::SQL::error);
        my %fk    = $new_schema->fk;
        my @ls    = sort keys %{$fk{$name}};
        my $rel   = $self->new_relation ($fk_table, $self->name);
        my $rel_cond = new GT::SQL::Condition;
        foreach my $col (@ls) {
            $rel_cond->add ( $name . '.' . $fk{$name}->{$col}, 'IS', \'NULL' );
            my $my_col = $fk{$name}->{$col};
            my $sel_limit = '(' . join (",", map { $_->[ $self->{schema}->{cols}->{$my_col}->{pos} - 1 ] } @$q) . ')';
            next if ($sel_limit eq '()');
            $rel_cond->add($fk_table . '.' . $col, 'IN', \$sel_limit);
        }
        my $sth   = $rel->select ('left_join', \@ls, $rel_cond) or return;
        my $cols  = $new_schema->cols;

        $ret        = $sth->rows;
        my $pk_vals = $sth->fetchall_arrayref;
        if (@ls > 1) {
            for my $row (@{$pk_vals}) {
                $new_schema->delete({ map { $ls[$_] => $row->[$_] } 0 .. $#ls }) or return;
            }
        }
        elsif (@ls == 1) {
            my $str;
            if ($cols->{$ls[0]}->{type} =~ /INT/) {
                $str = '(' . join("," => map { $_->[0] } @{$pk_vals}) . ')';
            }
            else {
                $str = '(' . join("," => map { $self->quote($_->[0]) } @{$pk_vals}) . ')';
            }
            if ($str ne '()') {
                $new_schema->delete(GT::SQL::Condition->new($ls[0], 'IN', \$str));
            }
        }
    }
    return 1;
}
END_OF_SUB

# Returns a hash of all columns that have positive weights.
$COMPILE{_weight_cols} = __LINE__ . <<'END_OF_SUB';
sub _weight_cols {
    my $self = shift;
    return map {
        $self->{schema}->{cols}->{$_}->{weight}
          ? ($_ => $self->{schema}->{cols}->{$_}->{weight})
          : ()
    } keys %{$self->{schema}->{cols}};
}
END_OF_SUB

# a hash of all columns that have form_type file
$COMPILE{_file_cols} = __LINE__ . <<'END_OF_SUB';
sub _file_cols {
    my $self = shift;
    $self->{_file_cols} = {
        map {
            ($self->{schema}->{cols}->{$_}->{form_type} and uc $self->{schema}->{cols}->{$_}->{form_type} eq 'FILE')
                ? ($_ => $self->{schema}->{cols}->{$_})
                : ()
        } keys %{$self->{schema}->{cols}}
    } if !$self->{_file_cols} or shift;

    %{$self->{_file_cols}};
}
END_OF_SUB

# Returns true if first argument is a primary key.
$COMPILE{_is_pk} = __LINE__ . <<'END_OF_SUB';
sub _is_pk {
    for (@{$_[0]->{schema}->{pk}}) {
        return 1 if $_ eq $_[1];
    }
    return 0;
}
END_OF_SUB

$COMPILE{_is_fk} = __LINE__ . <<'END_OF_SUB';
sub _is_fk {
# -------------------------------------------------------------------
# Returns true if first argument is a foreign key.
#
    foreach (keys %{$_[0]->{schema}->{fk}}) {
        if (exists $_[0]->{schema}->{fk}->{$_}->{$_[1]}) {
            return 1;
        }
    }
    return 0;
}
END_OF_SUB

# Returns true if first argument is not null.
$COMPILE{_is_not_null} = __LINE__ . <<'END_OF_SUB';
sub _is_not_null {
    return(
        exists $_[0]->{schema}->{cols}->{$_[1]}->{not_null}
        and $_[0]->{schema}->{cols}->{$_[1]}->{not_null}
    );
}
END_OF_SUB

# Returns true if first argument is indexed.
$COMPILE{_is_indexed} = __LINE__ . <<'END_OF_SUB';
sub _is_indexed {
    my ($self, $col) = @_;
    foreach my $index_name (keys %{$self->{schema}->{index}}) {
        foreach my $index_col (@{$self->{schema}->{index}->{$index_name}}) {
            return 1 if $index_col eq $col;
        }
    }
    return 0;
}
END_OF_SUB

# Returns true if first argument is uniquely indexed.
$COMPILE{_is_unique} = __LINE__ . <<'END_OF_SUB';
sub _is_unique {
    my ($self, $col) = @_;
    foreach my $index_name (keys %{$self->{schema}->{unique}}) {
        foreach my $index_col (@{$self->{schema}->{unique}->{$index_name}}) {
            return 1 if $index_col eq $col;
        }
    }
    return 0;
}
END_OF_SUB

$COMPILE{_get_indexer} = __LINE__ . <<'END_OF_SUB';
sub _get_indexer {
#-------------------------------------------------------------------------------
    my $self = shift;
    $self->debug("CREATING GT::SQL::Indexer OBJECT") if ($self->{_debug} > 2);
    require GT::SQL::Search;
    my $indexer = $self->{gt_sql_indexer} ||= GT::SQL::Search->load_indexer(
        table => $self
    );
    $indexer->debug_level($self->{_debug});
    return $indexer;
}
END_OF_SUB

1;

__END__

=head1 NAME

GT::SQL::Table - a perl interface to manipulate a single SQL table.

=head1 SYNOPSIS

    my $sth = $table->select ( { Column => $value, Column2 => $value2 }, ['Column3'] );
    $table->delete ( { Column => $value } );
    $table->insert ( { Column1 => $val, Column2 => $value2 } );
    $table->update ( { Set => $val }, { where => $val2 } );

=head1 DESCRIPTION

GT::SQL::Table provides methods to add, modify, delete and search over a single
SQL table.

The following methods are provided.

=head2 query, query_sth

C<query> provides a simple and powerful method to search a table. It takes as
input either a hash, hash ref or CGI object making it especially useful
searching from web forms.

    my $results = $db->query ( $in );

The return of C<query> is an arrayref of arrayrefs. C<query_sth> returns an STH
that you can fetch rows from.

Typical usage to go through the results is:

    my $results = $db->query ( { Title => 'foobar' } );
    if ($results) {
        foreach my $result (@$results) {
            ...
        }
    }

To specify what to search, you simply pass in column => search value. However,
you can also pass in a lot of options to enhance your search:

Find all rows with field_name = value:

    field_name    => value

Find all rows with field_name > value:

    field_name    => ">value"

Find all rows with field_name < value:

    field_name    => "<value"

Find all rows with field_name > value:

    field_name-gt => value

Find all rows with field_name < value:

    field_name-lt => value

Find all rows where any field_name = value:

    keyword       => value

Find all rows using indexed search (see weights):

    query         => value

Set to 1, use '=' comparison, 0/unspecified use 'LIKE '%val%' comparision:

    ww            => 1

Search using LIKE for column 'Title' (valid opts are '=', '>', '<' or 'LIKE'):

    Title-opt     => 'LIKE'

Set to 1, OR match results, 0/unspecified AND match results:

    ma            => 1

Return a max of n results, defaults to 25:

    mh            => n

Return page n of results:

    nh            => n

Sort by 'Title' column:

    sb            => 'Title'

Sort in ascending (ASC) or descending (DESC) order:

    so            => 'ASC'

=head2 select

Select provides a way to implement almost any sql SELECT statement.

An executed statement handle is returned that you can call the normal fetchrow,
fetchrow_array, fetchrow_hashref, etc on.

    my $sth = $obj->select;

is equivalant to "SELECT * FROM Table"

    my $sth = $obj->select ( { Col => Val } );

is equivalant to "SELECT * FROM Table WHERE Col = 'Val'".

    my $sth = $obj->select ( { Col => Val }, ['Col2', 'Col3'] );

is equivalant to "SELECT Col2,Col3 FROM Table WHERE Col => 'Val'".

So you can pass in a hash reference which represents the where clause, and an
array reference where represents what you want to select on.

If you need more complex where clauses, you should use a condition object
instead of a hash reference. See L<GT::SQL::Condition> for more information.

Notes:

=over 4

=item quoting in where

All arguments in the where clause are automatically quoted. If you don't want
quotes, you should pass in a scalar reference as in:

    my $sth = $obj->select ( { Col => \"NOW()" } );

which turns into "SELECT * FROM Table WHERE Col = NOW()".

=item quoting in select

Nothing in the select will be quoted, so to use functions, simply pass in what
you want:

    my $sth = $obj->select ( [ 'COUNT(*)' ] );

which turns into "SELECT COUNT(*) FROM Table".

=back

To specify LIMIT, or GROUP BY, or ORDER BY or other SELECT clauses that come
after the WHERE, you should use select_options below.

=head2 select_options

This method provides a way for you to specify select options such as LIMIT and
SORT_BY.

    $obj->select_options (@OPTIONS);

@OPTIONS should be a list of options you want appended to your next select.

For example,

    $obj->select_options('ORDER BY Foo', 'LIMIT 50');
    $obj->select;

would turn into "SELECT * FROM Table ORDER BY Foo LIMIT 50".

=head2 count

This method will allow you to count records based on a where clause.

    my $count = $obj->count ($condition);

count() takes either a condition or a hash reference. If no argument is
provided, it is equivalant to "SELECT COUNT(*) FROM Table", or total number of
rows.

=head2 total

This method returns the total number of results in the table(s).  To specify a
condition call I<count>.

    $total = $obj->total;

and is equivalant to $obj->count;

=head2 hits

This method returns the number of hits from that last query B<without> the
limit clause if there was one.

    $hits = $obj->hits;

For example, if you do a search and to get rows 20, 30 of results:

    $obj->select_options ("LIMIT 20, 10"); $obj->select ( { Column => 'Foo' });

this translates into: SELECT * FROM Table WHERE Column = 'Foo' LIMIT 20,10

To see the total number of results that the query would have retrieved you
call:

    $hits = $obj->hits;

This generates a: SELECT COUNT(*) FROM Table WHERE Column = 'Foo' to be run and
the total number of matches to be returned.

=head2 get

This method allows for a simple interface to retrieving records from the
table(s).

    my $rec_hash_ref  = $obj->get ($val);
    my $rec_hash_ref  = $obj->get ($val, 'HASH', ['col1', 'col2']);
    my $rec_array_ref = $obj->get ($val, 'ARRAY');

The first argument is the primary key value of the record you want to retrieve.

The second argument is a format option. It can be either 'ARRAY' or 'HASH' and
determines whether you are returned a HASH reference or an ARRAY reference. The
default is 'HASH', and it is optional.

The last argument is a list of column names you want retrieved. C<get> defaults
to returning the entire record, but if you only need specific columns, you can
ask for the ones you want.

For example:

    my $employee = $emp_db->get ('Alex');

would return a hash ref of the record whose primary key is equal to 'Alex'.

    my $emp_addr = $emp_db->get ('Alex', 'HASH', ['City', 'State', 'ZipCode']);

would return a hash ref of only the three fields City, State, ZipCode for the
record whose primary key equals Alex.

=head2 add

Method to add an entry into the database. This method can take it's arguments
one of three ways.

    $obj->add ($CGI_OBJECT);

    -or-

    $obj->add (
                {
                    col1 => $val1,
                    col2 => $val2,
                    ...
                }
            );

    -or-

    $obj->add (
                col1 => $val1,
                col2 => $val2,
                ...
            );

This method can take a cgi object, a hash reference or a hash. The keys of the
hash should be the names of the column and the values should be the values to
insert into the fields.  The CGI Object is not different. If the table has an
auto_increment field, the value of the last inserted record will be returned.

C<add> returns undef on failure. If successful, and the table has an
auto-increment field, the auto increment value is returned.  If there is no
auto increment value, then 1 is returned. Any errors will be in
$GT::SQL::error.

Passing in  GT_SQL_SKIP_CHECK => 1 will have the table module skip any error
checking it should perform.

Passing in GT_SQL_SKIP_INDEX => 1 will not index the fields. You can also use
the C<indexing> method to do this.

=head2 insert

C<insert> is a lower level add. The main differences between C<add> and
C<insert> are that add performs a not null check, and add returns the id of the
just inserted value.

C<insert> does not perform a not null check. Also, insert returns the statement
handle used to do the insert (so you can call $sth->insert_id to get the auto
increment).

=head2 insert_multiple

C<insert_multiple> will try and use Mysql's multiple insert syntax:

    INSERT INTO Table (col1, col2, col3)
    VALUES (val1, val2, val3), (val4, val5, val6), ...

If this is not supported, it will fall back and loop through the values and use
C<insert>. No error checking is done on the values!

=head2 modify

This method is designed for modifying a single entry in the table. It takes as
input a hash, hash ref or CGI object,  which is assumed to represent a single
row with all fields intact.

C<modify> will then look for the primary key in the input and set all fields
for that row equal to what was passed in.

You need to pass in a complete record! If you just want to update one column,
you probably want to use C<update> instead, as doing:

    my $result = $obj->modify ( column1 => 'Foo' );

will blank out all the other fields and set just column1 to Foo.

C<modify> returns undef on failure, 1 on success. The error message will be
available in $GT::SQL::error.

=head2 update

This method provides a more robust way to update multiple entries in the table.

    my $result = $obj->update(
        {
            col1 => $val1,
            col2 => $val2,
            ...
        },
        $condition
    );

    -or-

    my $result = $obj->update(
        {
            col1 => $val1,
            col2 => $val2,
            ...
        },
        {
            col1 => $val1,
            col2 => $val2,
            ...
        }
    );

In both these cases the first argument is a hash reference with the column
names as the keys and the new values you want the columns to hold as the
values. The second argument can either be a condition object or a hash
reference. If it is a hash reference the keys will be used as the column names
and the values will be taken as the current column values for the where clause
to update the table.

    $obj->update ( { Setme => 'NewValue'}, { WhereCol => 5 });

would set the column 'Setme' to 'NewValue' where the column 'WhereCol' is 5.
This translates to:

    UPDATE Table SET SetMe='NewValue' WHERE WhereCol = 5

If the second argument is a GT::SQL::Condition object the condition object will
be used to build the where clause with.  Please see L<GT::SQL::Condition> for a
description of what you can do with a where clause.

    my $condition = new GT::SQL::Condition ( 'WhereCol', 'LIKE', 'Foo%' );
    $obj->update ( { Setme => 'Newvalue'}, $condition);

would translate to:

    UPDATE Table SET Setme = 'Newvalue' WHERE WhereCol LIKE 'Foo%'

The condition can now much more complex where clauses though.

C<update> returns undef on failure and the a L<GT::SQL::Driver> statement
handle on success. The error message will be available in $GT::SQL::error.

Passing in GT_SQL_SKIP_CHECK => 1 as a third option to C<update> will have the
table module skip any error checking it should perform.

Passing in GT_SQL_SKIP_INDEX => 1 will not index the fields. You can also use
the C<indexing> method to do this.

=head2 delete

This method provides a robust interface to delete entries from your table(s)
using join and or foreign key relations.

    my $result = $obj->delete ($condition);

You can pass into C<delete> either a condition object to delete multiple
entries, or a scalar value to delete the row whose primary key equals the
value. If you have a multiple primary key, then you can pass in an array ref to
delete that row.

    my $result = $obj->delete (
                {
                    col1 => $val1,
                    col2 => $val2,
                    ...
                }
            );

    -or-

    $obj->delete ( $val );

    -or-

    $obj->delete ( [$val1, $val2] );

C<delete> returns undef on failure, 1 on success. The error message will be
available in $GT::SQL::error.

=head2 delete_all

This method takes no arguments and will erase all entries from a table.

=head2 Table Properties

Table provides a lot of methods to access information about the table:

=over 4

=item name

Provides the name of the table minus any prefix.

=item ai

Returns the name of the auto-increment field if any.

=item pk

Returns an array(ref) of primary key column names.

=item fk

Returns a hash of foreign key values.

=item fk_tables

Returns a list of tables with foreign keys pointing to this table.

=item index

Returns a hash ref of index name => array ref of column names that index uses.

=item unique

Returns a hash ref of unique index names => array ref of column names that
unique index uses.

=item B<all_indexes>

Returns the joined output of index and unique and primary key.

=item cols

Returns a hash(ref) of column name => column definition

=item default

Returns a hash(ref) of column name => default value.

=item size

Returns a hash(ref) of column name => size of column in SQL.

=item type

Returns a hash(ref) of column name => type of column in SQL.

=item form_display

Returns a hash(ref) of column name => name to display on auto generated forms
(think pretty name).

=item form_size

Returns a hash(ref) of column name => size of html form to generate.

=item form_type

Returns a hash(ref) of column name => type of html form to generate (checkbox,
select, text, etc).

=item form_names

Returns a hash(ref) of column name => array ref of form names. This is used for
multi option form elements like checkboxes and multi selects.  The name is what
is displayed to the user and not entered in the database.

=item form_values

Returns a hash(ref) of column name => array ref of form values. Same as above,
but this is the value that actually gets entered.

=item time_check

Returns a hash(ref) of column name => time check on or off. If set

=item regex

Returns a hash(ref) of column name => regular expression that all input must
pass before being inserted.

=item pos

Returns a hash(ref) of column name => position in table.

=item not_null

Returns a hash(ref) of column name => not null (whether the field is allowed to
be null or not).

=back

=head1 COPYRIGHT

Copyright (c) 2000 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: Table.pm,v 1.219 2002/08/12 02:00:34 jagerman Exp $

=cut