1217 lines
36 KiB
Perl
1217 lines
36 KiB
Perl
# ==================================================================
|
|
# 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
|