# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Base
#   Author  : Scott Beck
#   CVS Info : 087,071,086,086,085      
#   $Id: Creator.pm,v 1.74 2004/09/22 02:43:29 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description:
#   Class used to make changes to tables and create tables.
#

package GT::SQL::Creator;
# ===============================================================
use GT::SQL;
use GT::Base;
use GT::AutoLoader;
use strict;
use vars qw/@ISA $DEBUG $VERSION $error $ERROR_MESSAGE/;

$VERSION = sprintf "%d.%03d", q$Revision: 1.74 $ =~ /(\d+)\.(\d+)/;
$ERROR_MESSAGE = 'GT::SQL';
@ISA   = qw/GT::Base/;
$DEBUG = 0;

sub new {
# -------------------------------------------------------------------
# Setup a new creator object.
#
    my $this = shift;
    my $class = ref $this || $this;
    my $self = bless {}, $class;

# Get the arguments
    my $opts = {};
    if    (@_ == 0) { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH). No arguments") }
    elsif (@_ == 1 and ref $_[0] eq 'HASH') { $opts = shift }
    elsif (not @_ % 2) { $opts = {@_} }
    else { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH). Wrong arguments") }
    ref $opts->{table} or return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH); No table passed in to creator.");

    $self->{table}    = $opts->{table};
    $self->{connect}  = $opts->{connect};
    $self->{_debug}   = $opts->{debug}    || $DEBUG;
    $self->{_err_pkg} = $opts->{_err_pkg} || __PACKAGE__;

    $self->debug("OBJECT CREATED") if $self->{_debug} > 2;
    return $self;
}

##
# $obj->create;
# -------------------
#   Checks to see that the table is not there.
#   Returns undef if it is. If the table is not
#   there creates the table.
#
# $obj->create("force");
# -----------------------------
#   This will check to see if the table is there.
#   If it is create_table will drop the table
#   then create the current one.
##
sub create {
    my $self  = shift;
    my $force = shift || 'check';
    my $opts  = shift || {};

    $self->{table}->connect() or return;
# Error checking
    $self->{table}->check_schema or return;
    keys %{$self->{table}->cols} or return $self->fatal('NOTABLEDEFS');
    if ($self->_uses_weights) { $self->_get_indexer()->pre_create_table() or return }

    my $table_name = $self->{table}->name();

# Force the creation if force is specified
    if ($force eq 'force') {
        $self->debug("Forcing the table creation") if $self->{_debug} > 1;
        my $ret;
        {
            local ($SIG{__DIE__}, $@);
            eval { $ret = $self->{table}->do_query("SELECT COUNT(*) FROM $table_name") };
            $GT::SQL::error = '';
        }
        if (defined $ret) {
            $self->debug("Table $table_name exists. Dropping table") if ($self->{_debug} > 1);
            $self->drop_table;
        }
        else {
            $self->debug("Not dropping table $table_name because it does not exist") if $self->{_debug} > 1;
        }
    }
    elsif ($force eq 'check' or $force eq 'upgrade' ) {
        my $ret;
        {
            local ($SIG{__DIE__}, $@);
            eval { $ret = $self->{table}->do_query("SELECT COUNT(*) FROM $table_name") };
            $GT::SQL::error = '';
        }
        if (defined $ret) {
            if ( $force eq 'upgrade' ) {
                return $self->_consolidate( $opts );
            }
            else {
                return $self->warn(TBLEXISTS => $table_name);
            }
        }
    }

    $self->{table}->{driver}->create_table($force) or return;


# Set up some defaults
    $self->set_defaults;
    $self->{table}->save_state or return;

# now that the table has been made, if the user has requested weighted-indexing of tables, handle that
    if ($self->_uses_weights) { $self->_get_indexer()->post_create_table() or return }

# then handle anything related to file databases
    $self->_file_create_tables();
    return 1;
}

sub _uses_weights {
#-------------------------------------------------------------------------------
    return keys %{$_[0]->{table}->weight()}
}

$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 = GT::SQL::Search->load_indexer(
        table => $self->{table},
        debug => $self->{_debug}
    );
    return $indexer;
}
END_OF_SUB

$COMPILE{_file_create_tables} = __LINE__ . <<'END_OF_SUB';
sub _file_create_tables {
# creates file upload tables if required
    my $self = shift;

    if ( $self->{table}->_file_cols() ) {

# ... create the table because we have file columns
        require GT::SQL::File;
        my $ftable = GT::SQL::File->new(
                                            table => $self->{table},
                                            connect => $self->{connect}
                                        );
        $ftable->debug_level($self->{_debug});
        $ftable->install({ parent_tablename => $self->{table}->name() });

    };
    $self->{table}->_file_cols(1);
}
END_OF_SUB

sub set_defaults {
    my $self      = shift;
    my %cols      = ref $_[0] ? %{shift()} : $self->{table}->cols();
    my %file_defs = (form_type => 'FILE', form_size => '20', file_save_in => '.', file_save_scheme => 'HASHED');

    for my $col (keys %cols) {

        my $attrib = $cols{$col};
        if ($attrib->{type} =~ /char/i) {
            $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'TEXT';
            $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 20;

            if ($attrib->{form_type} and $attrib->{form_type} =~ /file/i) {
                my $col_info = $self->{table}->{schema}->{cols}->{$col};
                for (qw(form_type form_size file_save_in file_save_scheme)) {
                    $col_info->{$_} ||= $file_defs{$_} unless $col_info->{$_};
                }

                $col_info->{file_log_path} ||= $col_info->{file_save_in};
            }
        }
        elsif ($attrib->{type} =~ /text|blob/i) {
            $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'TEXTAREA';
            $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 30;
        }
        elsif ($attrib->{type} =~ /int|double|float/i) {
            $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'TEXT';
            $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 10;
        }
        elsif ($attrib->{type} =~ /enum/i) {
            $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'SELECT';
        }
        elsif ($attrib->{type} =~ /date|timestamp/i) {
            $self->{table}->{schema}->{cols}->{$col}->{form_type} ||= 'DATE';
            $self->{table}->{schema}->{cols}->{$col}->{form_size} ||= 20;
        }
    }

}


##
#   $obj->load_table;
#   -----------------
#       Creates a schema based on an existing sql
#       table and saves it.
##
$COMPILE{load_table} = __LINE__ . <<'END_OF_SUB';
sub load_table {
    my $self = shift;
    $self->{table}->connect() or return;
    $self->_load_table(@_) or return;
    $self->{table}->save_state() or return;
}
END_OF_SUB

$COMPILE{_load_table} = __LINE__ . <<'END_OF_SUB';
sub _load_table {
    my $self = shift;
    $self->debug("DESCRIBE $self->{table}->{name}") if $self->{_debug};
    my $sth = $self->{table}->{driver}->prepare("DESCRIBE $self->{table}->{name}") or return;
    $sth->execute() or return;
    my ($pos, %index, %unique, %cols, @pk, %other) = (1);

    # Default to the current ai value, if any, because some databases don't
    # associate an increment to a value (such a postgres, where sequences are
    # completely separate from tables and columns)
    my $ai = $self->{table}->ai;

    my $table_name = $self->{table}->name;
    my %col_case_map = map { lc $_ => $_ } keys %{$self->{table}->cols};
    my %index_case_map = map { lc $_ => $_ } keys %{$self->{table}->index};
    my %unique_case_map = map { lc $_ => $_ } keys %{$self->{table}->unique};

# Get the column defintions.
    while (my $col = $sth->fetchrow_hashref) {
        my $name = $col_case_map{lc $col->{Field}} || $col->{Field};
        my $type = $col->{Type};
        my $not_null = $col->{Null} ? 0 : 1;
        my $default  = ($col->{Default} and $col->{Default} ne 'NULL') ? $col->{Default} : undef;
        $ai = $name if $col->{Extra} and $col->{Extra} =~ /AUTO/i;
        $_ = $type;

        if (/^((?:var)?char)\((\d+)/i) {
            %other = (type => uc $1, size => $2);
            $other{binary} = 1 if /binary/i;
        }
        elsif (/^(var)?binary\((\d+)/i) {
            %other = (type => "\U${1}char", size => $2);
            $other{binary} = 1;
        }
        elsif (/^((?:tiny|small|medium|big)?int)/i) {
            %other = (type => uc $1);
            $other{zerofill} = 1 if /zerofill/i;
            $other{unsigned} = 1 if /unsigned/i;
        }
        # decimal(10,5)
        elsif (/^(?:decimal)\((\d+),\s*(\d+)\)/i) {
            %other = (type => 'DECIMAL', precision => $1, scale => $2);
            $other{zerofill} = 1 if /zerofill/i;
        }
        elsif (/^(?:double|float8)/i) {
            %other = (type => 'DOUBLE');
            $other{zerofill} = 1 if /zerofill/i;
        }
        elsif (/^(?:float|real)/i) {
            %other = (type => 'REAL');
            $other{zerofill} = 1 if /zerofill/i;
        }
        elsif (/^(datetime|date|timestamp|time|year|(?:tiny|medium|long)?(?:text|blob))/i) {
            %other = (type => uc $1);
        }
        elsif (/^enum\('([^\)]+)'\)/i) {
            %other = (
                type   => 'ENUM',
                values => [split /'\s*,\s*'/, $1]
            );
        }
        else {
            return $self->fatal(BADTYPE => $type);
        }
        my %col = (
            pos => $pos,
            %other
        );
        $col{default} = $default if defined $default;
        $col{not_null} = 1 if $not_null;
        $cols{$name} = \%col;
        $pos++;
    }

    # Retrieve index information
    $sth = $self->{table}->{driver}->prepare("SHOW INDEX FROM $self->{table}->{name}") or return;
    $sth->execute() or return;
    my ($pk_index_name, @pk_index_cols);
    while (my $index = $sth->fetchrow_hashref) {
        my $name = lc $self->{table}->{driver}->extract_index_name($self->{table}->{name}, $index->{index_name});
        $name = ($index->{index_unique} ? $unique_case_map{$name} : $index_case_map{$name}) || $name;
        my $field = $col_case_map{lc $index->{index_column}} || $index->{index_column};
        if ($index->{index_primary}) {
            push @pk, $field if $index->{index_primary};
            # Ignore primary indexes that we don't know about because pk's CAN
            # overlap regular indexes in some databases
            next unless exists $unique_case_map{$name} or exists $index_case_map{$name};
        }
        if ($index->{index_unique}) {
            push @{$unique{$name}}, $field;
        }
        else {
            push @{$index{$name}}, $field;
        }
    }

    my $old_cols = $self->{table}->cols;
    for my $col (keys %cols) {
        for my $val (keys %{$old_cols->{$col}}) {
            $cols{$col}->{$val} = $old_cols->{$col}->{$val} unless exists $cols{$col}->{$val};
        }
    }
    $self->{table}->cols(\%cols);
    $self->{table}->pk(@pk);
    $self->{table}->ai($ai || '');
    $self->{table}->index(\%index);
    $self->{table}->unique(\%unique);

    return 1;
}
END_OF_SUB

##
# $obj->drop_table;
# -----------------
#   Drops the current table.
##
$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB';
sub drop_table {
    my $self = shift;
    require GT::SQL::Editor;
# Were ->{fk} there, Editor would wipe the current table from all fk_tables
    my $fk = delete $self->{table}->{schema}->{fk};
    my $ret = GT::SQL::Editor->new(
        debug => $self->{_debug},
        table => $self->{table},
        connect => $self->{table}->{connect}
    )->drop_table(@_);
    $self->{table}->{schema}->{fk} = $fk;
    $ret;
}
END_OF_SUB

##
# $obj->clear_schema
# ------------------
#     Resets the schema to an empty schema.
##
sub clear_schema {
    my $self = shift;

    %{$self->{table}->{schema}} = (
        index     => {},
        unique    => {},
        cols      => {},
        pk        => [],
        fk        => {},
        subclass  => {},
        ai        => '',
        fk_tables => []
    );
    $self->{table}->{search_driver} = 'NONINDEXED';
}

##
# $obj->cols($hash_ref);
# ---------------------------
#   Sets the relations columns as specified by $hash_ref.
#   the hash should look like { $col_name => { type => 'int' } }.
#
# $obj->cols(
#     $col1 => {
#         type     => 'int',
#         not_null => 1
#     },
#     $col2 => { ... }
# );
# --------------------------
#   Sets the relations columns as specified via method
#   params.
##
sub cols {
    my $self = shift;
    return $self->{table}->cols(@_);
}

##
# $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.
##
sub pk {
    my $self = shift;
    $self->{table}->pk(@_) or return;
    return 1;
}

##
# $obj->ai($column);
# -----------------------
#   Sets the AUTO INCRIMENT column.
##
sub ai {
    my $self = shift;
    $self->{table}->ai(@_) or return;
    return 1;
}

##
# $obj->name($table_name);
# -----------------------------
#   Sets the name for the table to create.
##
sub name {
    my $self = shift;
    $self->{table}->name(@_) or return;
    return 1;
}

##
# $obj->form_display($nice_name);
# ------------------------
#   Sets the name of the table as it is displayed
#   using the Display module.
##
sub form_display {
    my $self = shift;
    $self->{table}->form_display(@_) or return;
    return 1;
}

##
# $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.
##
sub index {
    my $self = shift;
    $self->{table}->index(@_) or return;
    return 1;
}

##
# $obj->search_driver( $searching_driver );
# --------------------------------------------------
##
sub search_driver {
    my $self    = shift;
    $self->{table}->search_driver(@_) or return;
    return 1;
}

##
# $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.
##
sub unique {
    my $self = shift;
    $self->{table}->unique(@_) or return;
    return 1;
}

##
# $obj->fk({
#     RELATION_NAME => {
#         SOURCE_FIELD_1 => TARGET_FIELD_1,
#         ...
#         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.
##
sub fk {
    my $self = shift;
    $self->{table}->fk(@_) or return;
    return 1;
}

sub subclass { return shift->{table}->subclass(@_) }

##
# $obj->save_schema
#   Saves the schema (.def) file. Useful when loading tables
#   that already exist, but you don't want to overwrite.
##
sub save_schema {
    return unless ($_[0]->{table});
    return $_[0]->{table}->save_state();
}

$COMPILE{_consolidate} = __LINE__ . <<'END_OF_SUB';
sub _consolidate {
#-------------------------------------------------------------------------------
    my $self         = shift;
    my $opts         = shift;
    my $long_name    = $self->{table}->{name};
    my $table_name   = $long_name;
    my $prefix       = $self->{connect}->{PREFIX};
    $table_name      =~ s,^$prefix,,;

    my $file = "$self->{connect}->{def_path}/$long_name.def";

#    $self->clear_schema();
    my $table        = $self->{table}->table( $table_name ) or die $GT::SQL::error;

    $table->connect();
    my $source       = $table->{schema};
    my $destination  = $self->{table}->{schema};

# HANDLE COLUMNS
    my $s_cols       = $source->{cols};
    my $d_cols       = $destination->{cols};

# special vars
    my ( %POSITION, %CHANGED, %REMOVED, %ADDED );

# compare the table columns from source to destination
    my ( $cols, %col_order );
    %col_order       = map { $_ => $s_cols->{$_}->{'pos'} } keys %$s_cols;

    for my $col_name ( keys %col_order ) {

        if ( $d_cols->{$col_name} ) {

            if ( _is_different( $d_cols->{$col_name}, $s_cols->{$col_name} ) ) {

                for my $option ( %{$d_cols->{$col_name}} ) {

                    my $d_opts  = $d_cols->{$col_name};
                    my $s_opts  = $s_cols->{$col_name};

                    if ( $option eq 'pos' ) {
                        if ( $d_opts->{pos} != $s_opts->{pos} ) {
                            $POSITION{$col_name} = $d_opts;
                        };
                    }

                    elsif ( ref $d_opts->{$option} eq 'ARRAY' ) {
                        my $d_ar = $d_opts->{$option};
                        my $s_ar = $s_opts->{$option};
                        if ( @$d_ar != @$s_ar ) {
                            $CHANGED{$col_name} = $d_cols->{$col_name};
                        }
                        else {
                            for my $index ( 0..( scalar(@$d_ar)-1 ) ) {
                                if ( $d_ar->[$index] != $s_ar->[$index] ) {
                                    $CHANGED{$col_name} = $d_cols->{$col_name};
                                }
                            }
                        }
                    }

                    else {
                        ( $d_opts->{$option} ne $s_opts->{$option} ) and $CHANGED{$col_name} = $d_cols->{$col_name};
                    }

                }

            }

        }

        else {
            $REMOVED{$col_name} = $s_cols->{$col_name};
        };

    }

# compare the table columns from destination to source
    %col_order       = map { $_ => $d_cols->{$_}->{'pos'} } keys %$d_cols;
    for my $col_name ( keys %col_order ) {
        if ( !$s_cols->{$col_name} ) {
            $ADDED{$col_name} = $d_cols->{$col_name};
        }
    }

# HANDLE INDEXES
    my $d_idx           = $destination->{index};
    my $s_idx           = $source->{index};
    my %index_order     = map { $_ => 1 } ( keys %$d_idx, keys %$s_idx );
    my %INDEXES         = ();
    for my $idx_name ( keys %index_order  ) {
        if ( $d_idx->{$idx_name} and $d_idx->{$idx_name} ) {
            my $s_cols  = join "|", sort @{$d_idx->{$idx_name} || []};
            my $d_cols  = join "|", sort @{$s_idx->{$idx_name} || []};
            if ( $s_cols ne $d_cols ) {
                $INDEXES{$idx_name} = $d_idx->{$idx_name};
            }
            else {
                $INDEXES{$idx_name} = 'EQ';
            }
        }
        elsif ( !$d_idx->{$idx_name} and $s_idx->{$idx_name} ) {
            $INDEXES{$idx_name} = 'REMOVED';
        }
        elsif ( !$s_idx->{$idx_name} and $d_idx->{$idx_name} ) {
            $INDEXES{$idx_name} = 'ADDED';
        }
    }

# HANDLE AUTOINCREMENT
    my $AI  = undef;
    if ( $destination->{ai} eq $source->{ai} ) {
        $AI = 'EQ';
    }
    else {
        $AI = $destination->{ai};
    }

# HANDLE PK
    my $PK  = undef;
    $d_cols  = join "|", sort @{$destination->{pk} || []};
    $s_cols  = join "|", sort @{$source->{pk} || []};
    if ( $d_cols eq $s_cols ) {
        $PK = 'EQ';
    }
    else {
        $PK = $destination->{pk};
    }

# HANDLE FK
    my %FK   = ();
    my $d_fk = $destination->{fk};
    my $s_fk = $source->{fk};
    %index_order     = map { $_ => 1 } ( keys %$d_fk, keys %$s_fk );
    for my $col_name ( keys %$d_fk ) {
        if ( _is_different( $d_fk->{ $col_name }, $s_fk->{ $col_name } ) ) {
            $FK{$col_name} = $s_fk->{ $col_name };
        }
        else {
            $FK{$col_name} = 'EQ';
        }
    }

# HANDLE SUBCLASS
    my %SUBCLASS = ();
    my $d_sc     = $destination->{subclass};
    my $s_sc     = $source->{subclass};
    %index_order = map { $_ => 1 } ( keys %$d_sc, keys %$s_sc );
    for my $key ( keys %index_order ) {
        if ( _is_different( $d_fk->{ $key }, $s_fk->{ $key } ) ) {
            $SUBCLASS{ $key } = $d_fk->{ $key } ;
        }
        else {
            $SUBCLASS{ $key } = 'EQ';
        }
    }

# HANDLE UNIQUE
    my $d_uni           = $destination->{unique};
    my $s_uni           = $source->{unique};
    my %unique_order    = map { $_ => 1 } ( keys %$d_uni, keys %$s_uni );
    my %UNIQUE = ();
    for my $idx_name ( keys %unique_order  ) {
        if ( $d_uni->{$idx_name} and $d_uni->{$idx_name} ) {
            my $s_cols  = join "|", sort @{$d_uni->{$idx_name}};
            my $d_cols  = join "|", sort @{$s_uni->{$idx_name}};
            if ( $s_cols ne $d_cols ) {
                $UNIQUE{$idx_name} = $d_uni->{$idx_name};
            }
            else {
                $UNIQUE{$idx_name} = 'EQ';
            }
        }
        elsif ( !$d_uni->{$idx_name} and $s_uni->{$idx_name} ) {
            $UNIQUE{$idx_name} = 'REMOVED';
        }
        elsif ( !$s_uni->{$idx_name} and $d_uni->{$idx_name} ) {
            $UNIQUE{$idx_name} = 'ADDED';
        }
    };

# Summon callback if required
    $opts->{callback} and ( &{$opts->{callback}}( $self, $table, \%POSITION, \%CHANGED, \%REMOVED, \%ADDED, \%INDEXES, $AI, $PK, \%SUBCLASS, \%UNIQUE  ) or return );

# if position movements are required we must read all the data into a temp
# table first
    my $DO_POSITION = 0;
    $DO_POSITION    = $self->_create_temp_table( $table );

# ... change columns drop the columns
    my $sth         = $table->do_query(qq!DROP TABLE $long_name!) or die $GT::SQL::error;

# change the columns that have to be changed.
    $self->create( 'force' ) or die $GT::SQL::error;

# ... add the columns that have been removed in the past
    if ( %REMOVED and $self->{carry_over_columns} ) {
        my $editor  = $self->{table}->editor($table_name);
        my $pos     = scalar( keys %{$destination->{cols}} );
        for my $col_name ( sort { $REMOVED{$a}->{pos} <=> $REMOVED{$b}->{pos} } keys %REMOVED ) {
           $REMOVED{$col_name}->{pos} = ++$pos;
           $editor->add_col( $col_name, $REMOVED{$col_name} ) or die $GT::SQL::error;
        }
    }

# ... now copy the data over
    $cols        = $source->{cols};
    my $copy_cols   = join ",",
                        sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} }
                        grep { $self->{carry_over_columns} ? 1 : not $REMOVED{$_}  }
                        keys %$cols;
    $table->do_query(qq!
                       INSERT INTO $long_name
                       ($copy_cols)
                       SELECT $copy_cols
                       FROM $DO_POSITION
                       !) or die $GT::SQL::error;

    if ( %CHANGED ) {
        my $editor = $self->{table}->editor($table_name);
        for my $col_name ( keys %CHANGED ) {
            $editor->alter_col( $col_name, $CHANGED{$col_name} );
        }
    }

    return 1;
}
END_OF_SUB

$COMPILE{_create_temp_table} = __LINE__ . <<'END_OF_SUB';
sub _create_temp_table {
#-------------------------------------------------------------------------------
#
    my $self        = shift;
    my $table       = shift;
    my $source      = $table->{schema};
    my $def_path    = $self->{connect}->{def_path};

    use GT::MD5;
    my $table_name        = '';
    while ( -e ( $def_path . ( $table_name = GT::MD5::md5_hex( time() * rand() * 10000 ) ) ) ) {};
    my $c                 = $table->creator( $table_name );
    my $struct            = _copy_struct( $source );
    $struct->{fk_tables}  = {};
    $struct->{fk}         = {};
    $struct->{subclass}   = {};
    for ( values %{$struct->{cols}} ) { delete $_->{weight}; }

    $c->cols( %{$struct->{cols}} );
    %{$c->{table}->{schema}} = %$struct;
    $c->create( "force" ) or die $GT::SQL::error;

    my $tbl               = $table->table( $table_name );
    my $s_name            = $table->name();
    my $d_name            = $tbl->name();

    $tbl->connect();
    $tbl->do_query(qq|INSERT INTO $d_name SELECT * FROM $s_name|) or die $GT::SQL::error;

    return $table_name;
}
END_OF_SUB

$COMPILE{_copy_struct} = __LINE__ . <<'END_OF_SUB';
sub _copy_struct {
#-------------------------------------------------------------------------------
#
    my $source        = shift;
    my $copied_struct = undef;

    if ( ref $source eq 'HASH' ) {
        $copied_struct = {};
        for my $key ( keys %$source ) {
            $copied_struct->{ $key } = _copy_struct( $source->{$key} );
        }
    }

    elsif ( ref $source eq 'ARRAY' ) {
        $copied_struct = [];
        for my $element ( @$source ) {
            push @$copied_struct, _copy_struct( $element );
        }
    }

    else {
        $copied_struct = $source;
    }

    return $copied_struct;
}
END_OF_SUB


$COMPILE{_is_different} = __LINE__ . <<'END_OF_SUB';
sub _is_different {
#-------------------------------------------------------------------------------
    my ( $source, $destination ) = @_;

    if ( ref $source ne ref $destination ) { return 1 }

    if ( ref $source eq 'HASH' ) {
        my %keys = map { $_ => 1 } ( keys %$source, keys %$destination );
        for my $key ( keys %keys ) {
            _is_different( $source->{$key}, $destination->{$key} ) and return 1;
        }
    }

    elsif ( ref $source eq 'ARRAY' ) {
        my $ca      = scalar(@$source);
        my $cb      = scalar(@$destination);
        my $count   = ( $ca > $cb ) ? $ca : $cb;
        for my $index ( 0 .. ( $count - 1 ) ) {
            _is_different( $source->[$index], $destination->[$index] ) and return 1;
        }
    }

    else {
        ( $source ne $destination ) and return 1;
    }

    return;
}
END_OF_SUB

$COMPILE{_compare} = __LINE__ . <<'END_OF_SUB';
sub _compare {
#-------------------------------------------------------------------------------
# takes a hashref or arrayref and compares the two
#
    my ( $source, $destination ) = @_;

    if ( ref $source ne ref $destination ) { return [ 'NE_TYPES', ref $source, ref $destination ]; }

    if ( ref $source eq 'HASH' ) {
        return _comp_hash( $source, $destination );
    }
    elsif ( ref $source eq 'ARRAY' ) {
        return _comp_array( $source, $destination );
    }
    else {
        return;
    }

}
END_OF_SUB

$COMPILE{_comp_hash} = __LINE__ . <<'END_OF_SUB';
sub _comp_hash {
#-------------------------------------------------------------------------------
    my ( $source, $destination ) = @_;
    my %errs;
    my %keys = map { $_ => 1 } ( keys %$source, keys %$destination );

    for my $key ( keys %keys ) {

        my $src = $source->{$key};
        my $dst = $destination->{$key};
        if ( ref $src or ref $dst ) {
            $errs{$key} = _compare( $src, $dst );
        }
        elsif ( $src eq $dst  ) {
            $errs{$key} = 'EQ';
        }
        else {
            $errs{$key} = [ 'NE', $src, $dst ];
        }

    }

    return \%errs;
}
END_OF_SUB

$COMPILE{_comp_array} = __LINE__ . <<'END_OF_SUB';
sub _comp_array {
#-------------------------------------------------------------------------------
    my ( $source, $destination ) = @_;
    my @errs;
    my $ca      = scalar(@$source);
    my $cb      = scalar(@$destination);

    my $count   = ( $ca > $cb ) ? $ca : $cb;

    for my $index ( 0 .. ( $count - 1 ) ) {

        my $src = $source->[$index];
        my $dst = $destination->[$index];
        if ( ref $src or ref $dst ) {
            push @errs, _compare( $src, $dst );
        }
        elsif ( $src eq $dst  ) {
            push @errs, 'EQ';
        }
        else {
            push @errs, [ 'NE', $src, $dst ];
        }

    }

    return \@errs;
}
END_OF_SUB

1;

__END__

=head1 NAME

GT::SQL::Creator - an object to create SQL tables.

=head1 SYNOPSIS

    my $creator = $DB->creator('Newtable');
    $creator->cols(
        col1 => {
            pos => 1
            type => 'CHAR',
            size => 50
        },
        col2 => {
            pos => 2,
            type => 'INT',
            not_null => 1
        }
    );
    $creator->pk('col2');
    $creator->ai('col2');
    $creator->create or die "Unable to create: $GT::SQL::error";

=head1 DESCRIPTION

A creator object is used to build new SQL tables.

To get a new creator object, you need to call creator() from an existing
GT::SQL object.

The object that is returned has methods to set up your table. You will need to
call this method for each table you want to create.

    $creator = $obj->creator($table);

You must pass in the name of the table you want to create. This means if you
have a table named C<MyTable> you must call C<-E<gt>creator> with C<'MyTable'>
as the argument.

    $creator = $obj->creator('MyTable');

From this point you can call create methods on your creator object to define
and create your table.

=head2 cols

I<cols> is used to define the columns that will be in the new table by setting
properties such as the type, whether it allows null values, unsigned etc.

For detailed information on the types and options accepted, please see
L<GT::SQL::Types>.  The following describes the options accepted that do not
directly affect the underlying database:

=over 4

=item values

This specifies the values for the I<ENUM> column type.  If you are using an
I<ENUM> this must be set. The value for this should be an array reference of
the possible values for the I<ENUM> column. The values in the array that is
passed in will be quoted by DBI's quote method.

=item regex

This is a regex that the value must pass before being inserted
into the database.

=item form_display

This is a "pretty name" that will be used by the HTML module
for creating attractive forms automatically.

=item form_size

This is the form field length to be used by the HTML module.

=item form_type

This is the type of form to use by the HTML module: select, checkbox
radio, text, textarea or hidden.

=item form_names

This is for multi select or checkboxes and is an array ref of names
that get displayed.

=item form_values

This is for multi select or checkboxes and is an array ref of the
actual values that will be stored in the database.

=item time_check

This is only useful for TIMESTAMP fields. If set to 1, the module
will not allow you to update a record which has an older timestamp
then what is in the database. This is very helpful for protecting
against multiple updates.

=item weight

By giving an item a weight, GT::SQL will maintain a search index
table, and use that search index table when called using query.
This is only useful for indexing large text fields and should not
be used normally. The higher the weight, the more influence that
column will have on the result. So if a Title was set to weight
3 and a Description to weight 1, then when doing a search, a match
in the title would make the result appear before a match in the
description.

=back

So an example would look like:

    $creator->cols(
        $col1 => {
            type     => 'ENUM',
            values   => ['val1', 'val2' ... ],
            not_null => 1
        },
        $col2 => {
            ...
        }
    );

Sets the relations columns as specified via method
parameters. The only required key for the has is type.
However some column types require other values be set
such as I<ENUM> requires you specify the values.

=head2 pk

C<pk> lets you specify the primary keys for the current table.
This method can be called with an array of primary key columns
in which case all the specified column names in the array will
make up the primary keys. If you call it with a single scalar
value this is assumed to be the primary key for the table.

    $creator->pk($field1, $field2, ...);

=head2 ai

This specifies the auto increment column for the current table.
There can be only one auto increment column per table, it must
be a numeric type, it must be not null and it must be the
primary key. This limitation is checked when you call create.
If it is not a numeric column type you will get a fatal error
when you call create. If any of the other limitations fail
the creator class will correct.

=head2 index

C<index> allows you to specify the name and the columns for you
table indexes.

There are two ways to call this method.

You can set up all your indexes at once by calling it with
hash reference like this:

    $creator->index({
        $index1 => [field1, field2],
        $index2 => [field3, field4]
    });

The keys to this hash reference are the index names and
the values are an array reference containing the columns
that are part of the named index. The order for these
columns are maintained during the create.

You can also pass in one index at a time like this;

    $creator->index($index_name, $col1, ..., $coln);

The first argument is the name of the index and all the
rest are treated as columns that are part of this index.
Again the order of the columns are maintained.

=head2 unique

The C<unique> method allows you to specify the unique
indexes for the current table. This method takes the
same arguments as the C<index> method.

=head2 fk

C<fk> allows you to specify foreign key relations for your
tables. You CAN NOT specify foreign keys for tables that
have not been created yet. There are two ways to pass in
arguments to C<fk>. The first way is passing in a hash reference.

    $creator->fk({
        $FOREIGN_TABLE_NAME =>
        {
            $LOCAL_TABLE_COL_1 => $FOREIGN_TABLE_COL_1,
            ...
            $LOCAL_TABLE_COL_n => $FOREIGN_TABLE_COL_n
        }
    });

The keys to the hash are the names of the tables you are relating to.
The values are a hash reference that contain the name of the current
tables columns as the keys and the name of the foreign tables columns
that we are relating to as the values.

You cannot relate fields to your self. You also need to be careful
not to create circular references. This is checked when you call this
method. If there is a circular reference detected you will receive a
fatal error.

Foreign keys currently effect selects only.

=head2 search_driver

This affects how the weighted records are indexed. By default the
system will attempt to use best driver for the DBMS. However, if
you'd like to force the indexing system to an alternative type, such
as for MYSQL you can use this.

* note: though the MYSQL driver is faster, the internal indexing system
has better support for phrase searching and keyword searching.

To set the driver, call C<search_driver> with the appropriate driver
name. The following example will force the system into using the
internally implemented indexing scheme.

    $creator->search_driver('INTERNAL');

Currently, the only other valid option is "MYSQL".

-note-

The MYSQL driver occasionally behaves oddly with a small number of
records. In that case, set the search scheme to "INTERNAL".

=head2 create

This is the method you call to create your table after you have specified
all your table definitions. Several checks are made when this method is
called to ensure the table is created correctly.

One of the things that is done is checking to see that the table you are
trying to create does not exist. If the table does exist I<create> will
return undefined and set the error in $GT::SQL::error.

You can specify to have C<create> drop the table by passing in "force".

    $creator->create('force');

-or-

    $creator->create;

C<create> returns true on success and undef on failure.

=head1 COPYRIGHT

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

=head1 VERSION

Revision: $Id: Creator.pm,v 1.74 2004/09/22 02:43:29 jagerman Exp $

=cut