1083 lines
34 KiB
Perl
1083 lines
34 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Base
|
|
# CVS Info : 087,071,086,086,085
|
|
# $Id: Editor.pm,v 1.79 2007/09/05 04:42:31 brewt Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description:
|
|
# Class used to make changes to tables and create tables.
|
|
#
|
|
|
|
package GT::SQL::Editor;
|
|
# ==================================================================
|
|
use strict;
|
|
use vars qw/@ISA $DEBUG $VERSION $ERRORS $error $ERROR_MESSAGE/;
|
|
use GT::SQL;
|
|
use GT::SQL::Base;
|
|
use GT::AutoLoader;
|
|
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.79 $ =~ /(\d+)\.(\d+)/;
|
|
$ERROR_MESSAGE = 'GT::SQL';
|
|
@ISA = qw(GT::SQL::Base);
|
|
$DEBUG = 0;
|
|
|
|
sub new {
|
|
my $this = shift;
|
|
my $class = ref $this || $this;
|
|
my $self = bless {}, $class;
|
|
|
|
# Get the arguments
|
|
my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH)");
|
|
|
|
ref $opts->{table} or return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH). 'table' must be specified in the hash. It needs to be the an object from GT::SQL::Table.");
|
|
$self->{_debug} = $opts->{debug} || $DEBUG;
|
|
$self->{_err_pkg} = $opts->{_err_pkg} || __PACKAGE__;
|
|
$self->{table} = $opts->{table};
|
|
$self->{connect} = $opts->{connect};
|
|
|
|
# We almost always need to be connected.
|
|
$self->{table}->connect or return;
|
|
return $self;
|
|
}
|
|
|
|
|
|
#################################################################
|
|
##### Editing functions #####
|
|
#################################################################
|
|
##
|
|
# $obj->add_col($col_name,
|
|
# {
|
|
# size => 20,
|
|
# type => 'int',
|
|
# view_size => 20,
|
|
# form_display => "my col",
|
|
# regex => 'myregex'
|
|
# }
|
|
# );
|
|
# ------------------------------------
|
|
#
|
|
##
|
|
$COMPILE{add_col} = __LINE__ . <<'END_OF_SUB';
|
|
sub add_col {
|
|
my ($self, $name, $col) = @_;
|
|
|
|
$name and ref $col eq 'HASH' or return $self->fatal(BADARGS => '$obj->add_col(COLUMN_NAME, HASH_REF)');
|
|
my $c = $self->{table}->cols;
|
|
|
|
# Check the database instead of the def file so that we don't end up with
|
|
# an inability to add a column when the database and def files are out of
|
|
# sync.
|
|
my $exists = $self->{table}->{driver}->column_exists($self->{table}->name, $name);
|
|
$exists and return $self->warn(COLEXISTS => $name);
|
|
|
|
# You are not permitted to add a not_null column without a default to a table -
|
|
# the default is required for existing columns. You could, if you really want
|
|
# it with no default, create it with a default, then alter it to drop the
|
|
# default.
|
|
return $self->warn(NOTNULLDEFAULT => $name)
|
|
if $col->{not_null} and (not defined $col->{default} or $col->{default} eq '');
|
|
|
|
# count file columns
|
|
my %fcols_initial = $self->{table}->_file_cols();
|
|
|
|
# handle the search indexes
|
|
my $tmp_weight = {};
|
|
$tmp_weight = $self->_get_indexer()->pre_add_column($name, $col) or return if $col->{weight};
|
|
|
|
# get the column definition
|
|
my $col_props = $self->{table}->{driver}->column_sql($col);
|
|
my $table = $self->{table}->name;
|
|
|
|
# Auto add a new position number.
|
|
$col->{pos} = keys(%$c) + 1;
|
|
|
|
# Add the column into the table's column hash, for checking.
|
|
# N.B. - everything below this point _must_ reload the table information (i.e.
|
|
# via ->reset or ->reload) upon failure
|
|
$c->{$name} = $col;
|
|
|
|
# Check for conflicts
|
|
$self->{table}->check_schema or return $self->{table}->reset;
|
|
|
|
require GT::SQL::Creator;
|
|
GT::SQL::Creator::set_defaults($self, { $name => $col });
|
|
|
|
# Make the changes
|
|
$self->{table}->{driver}->add_column($table, $name, $col_props) or return $self->{table}->reset;
|
|
$self->{mods}->{$table} = $self->{table};
|
|
$self->save_state;
|
|
|
|
# Check for file columns
|
|
if (not keys %fcols_initial and uc $col->{form_type} eq 'FILE') {
|
|
require GT::SQL::File;
|
|
my $ftable = GT::SQL::File->new(parent_table => $self->{table}, connect => $self->{connect});
|
|
$ftable->debug_level($self->{_debug});
|
|
$ftable->install({ parent_tablename => $self->{table}->name() });
|
|
$self->{table}->_file_cols(1);
|
|
}
|
|
|
|
# finish off the search indexes
|
|
if ($col->{weight}) {
|
|
$self->_get_indexer()->post_add_column($name, $col, $tmp_weight) or return;
|
|
}
|
|
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->drop_col($col_name);
|
|
# ---------------------------
|
|
# Drops the column specified by $col_name.
|
|
# If the column is referenced returns an error.
|
|
# If the column is itself an fk reference, the foreign key is dropped.
|
|
#
|
|
# $obj->drop_col($col_name, "remove");
|
|
# -------------------------------------
|
|
# Drops column and all fk references to it.
|
|
#
|
|
##
|
|
$COMPILE{drop_col} = __LINE__ . <<'END_OF_SUB';
|
|
sub drop_col {
|
|
my $self = shift;
|
|
my $name = shift || return $self->fatal(BADARGS => '$obj->drop_col(COLUMN_NAME,[ STRING ])');
|
|
exists $self->{table}->cols->{$name} or return $self->warn(NOCOL => $name);
|
|
my $kill = shift;
|
|
|
|
my %fcols = $self->{table}->_file_cols();
|
|
my $table = $self->{table}->name;
|
|
if ($self->_is_referenced($table, $name)) {
|
|
if (defined $kill) {
|
|
$self->_remove_references($table, $name);
|
|
}
|
|
else {
|
|
return $self->warn(REFCOL => $name, $table);
|
|
}
|
|
}
|
|
|
|
my @fk_tables = grep exists $self->{table}->{fk}->{$_}->{$name}, keys %{$self->{table}->{fk}};
|
|
if (@fk_tables) {
|
|
$self->drop_fk($_, 1);
|
|
}
|
|
|
|
my $tmp_weight = {};
|
|
if (($self->{table}->cols->{$name} || {})->{weight}) {
|
|
$tmp_weight = $self->_get_indexer()->pre_delete_column($name, $self->{table}->cols->{$name}) or return
|
|
}
|
|
|
|
# Columns
|
|
my $old_col = delete $self->{table}->cols->{$name};
|
|
|
|
# Primary key
|
|
$self->{table}->pk(grep $_ ne $name, $self->{table}->pk);
|
|
|
|
# Foreign keys
|
|
while (my ($table, $fk) = each %{$self->{table}->fk}) {
|
|
for my $col (keys %$fk) {
|
|
if ($col eq $name) {
|
|
delete $self->{table}->fk->{$_}->{$col}
|
|
}
|
|
}
|
|
}
|
|
|
|
# Indexes and uniques
|
|
for my $index (qw/index unique/) {
|
|
my $ndx = $self->{table}->$index();
|
|
for (keys %$ndx) {
|
|
my @new = grep $_ ne $name, @{$ndx->{$_}};
|
|
if (@new) {
|
|
$ndx->{$_} = \@new;
|
|
}
|
|
else {
|
|
delete $ndx->{$_};
|
|
}
|
|
}
|
|
}
|
|
|
|
# Update the positions.
|
|
my $cols = $self->{table}->cols;
|
|
my $i;
|
|
for my $col (sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } keys %$cols) {
|
|
$cols->{$col}->{pos} = ++$i;
|
|
}
|
|
|
|
# Check for conflicts
|
|
$self->{table}->check_schema or return $self->{table}->reset;
|
|
|
|
# File Handling
|
|
if ($fcols{$name}) {
|
|
require GT::SQL::File;
|
|
my $ftable = GT::SQL::File->new(parent_table => $self->{table}, connect => $self->{connect});
|
|
$ftable->debug_level($self->{_debug});
|
|
$ftable->drop_col($name, $fcols{$name}->{file_save_scheme}) or return $self->{table}->reset;
|
|
$self->{table}->_file_cols(1);
|
|
}
|
|
|
|
# Finish off the index table stuff
|
|
if (($self->{table}->cols->{$name} || {})->{weight}) {
|
|
$tmp_weight = $self->post_delete_column($name, $self->{table}->cols->{$name}, $tmp_weight)
|
|
or return $self->{table}->reset;
|
|
}
|
|
|
|
# Make the changes - actually drop the column
|
|
$self->{table}->{driver}->drop_column($table, $name, $old_col) or return $self->{table}->reset;
|
|
$self->{mods}->{$table} = $self->{table};
|
|
$self->save_state;
|
|
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->alter_col($column_name, \%new_defs);
|
|
# -------------------------------------------
|
|
#
|
|
$COMPILE{alter_col} = __LINE__ . <<'END_OF_SUB';
|
|
sub alter_col {
|
|
my ($self, $col, $defs) = @_;
|
|
|
|
ref $defs eq 'HASH' or return $self->fatal(BADARGS => '$obj->alter_col(COLUMN_NAME, HASH_REF)');
|
|
exists $self->{table}->{schema}->{cols}->{$col} or return $self->warn(NOCOL => $col);
|
|
|
|
my %fcols = $self->{table}->_file_cols();
|
|
|
|
# Can't change the position, force it to what it was before.
|
|
my $orig = $self->{table}->{schema}->{cols}->{$col};
|
|
my $table = $self->{table}->{name};
|
|
|
|
# Set the position, can't be changed.
|
|
$defs->{pos} = $orig->{pos};
|
|
|
|
# Check to see if we need to update the SQL.
|
|
my $orig_sql = $self->{table}->{driver}->column_sql($orig);
|
|
my $new_sql = $self->{table}->{driver}->column_sql($defs);
|
|
my $change = $orig_sql ne $new_sql;
|
|
|
|
# If we've changed, check the keys.
|
|
if ($change) {
|
|
return $self->warn(REFCOL => $col, $table) if $self->_is_referenced($table, $col);
|
|
return $self->warn(COLREF => $col, $table) if exists $self->{table}->fk->{$col};
|
|
}
|
|
|
|
# Check for conflicts
|
|
my $old_col = $self->{table}->{schema}->{cols}->{$col};
|
|
$self->{table}->{schema}->{cols}->{$col} = $defs;
|
|
$self->{table}->check_schema or return $self->{table}->reset;
|
|
|
|
# adding a file column
|
|
if (not keys %fcols and $defs->{form_type} and lc $defs->{form_type} eq 'file') {
|
|
|
|
require GT::SQL::File;
|
|
my $ftable = GT::SQL::File->new({ parent_table => $self->{table}, connect => $self->{connect} });
|
|
$ftable->debug_level($self->{_debug});
|
|
$ftable->install({parent_tablename => $self->{table}->name() });
|
|
}
|
|
|
|
# removing a file column
|
|
elsif ($fcols{$col} and not ($defs->{form_type} and lc $defs->{form_type} eq 'file')) {
|
|
require GT::SQL::File;
|
|
my $ftable = GT::SQL::File->new({ parent_table => $self->{table}, connect => $self->{connect} });
|
|
$ftable->drop_col($col);
|
|
}
|
|
|
|
# Make the changes
|
|
if ($change) {
|
|
$self->{table}->{driver}->alter_column($table, $col, $new_sql, $old_col) or return $self->{table}->reset;
|
|
}
|
|
$self->{mods}->{$table} = $self->{table};
|
|
$self->save_state or return;
|
|
|
|
# finish off the file column setup
|
|
if ($defs->{form_type} and lc $defs->{form_type} eq 'file') {
|
|
$self->{table}->update({ $col => '' });
|
|
$self->{table}->_file_cols(1);
|
|
}
|
|
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->add_index($index_name => [ field1, field2 .. ]);
|
|
# --------------------
|
|
# Add a index to the table specified by
|
|
# $index_name. The array should contain fields
|
|
# that will be part of the index.
|
|
##
|
|
$COMPILE{add_index} = __LINE__ . <<'END_OF_SUB';
|
|
sub add_index {
|
|
my ($self, $index_name, $columns) = @_;
|
|
ref $columns eq 'ARRAY' or return $self->fatal(BADARGS => '$obj->add_index(INDEX_NAME => ARRAY_REF)');
|
|
|
|
# Do the columns exist?
|
|
for (@$columns) {
|
|
return $self->warn(NOCOL => $_) unless exists $self->{table}->cols->{$_};
|
|
}
|
|
|
|
exists $self->{table}->{schema}->{index}->{$index_name}
|
|
and return $self->warn(INDXEXISTS => $index_name);
|
|
|
|
my $table = $self->{table}->name;
|
|
|
|
# Check for conflicts
|
|
$self->{table}->{schema}->{index}->{$index_name} = $columns;
|
|
$self->{table}->check_schema or return $self->{table}->reset;
|
|
|
|
# Make the changes
|
|
$self->{table}->{driver}->create_index($table, $index_name, @$columns) or return $self->{table}->reset;
|
|
$self->{mods}->{$table} = $self->{table};
|
|
$self->save_state;
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->drop_index($index_name);
|
|
# --------------------------------
|
|
# Drops an index by the name $index_name.
|
|
##
|
|
$COMPILE{drop_index} = __LINE__ . <<'END_OF_SUB';
|
|
sub drop_index {
|
|
my ($self, $index_name) = @_;
|
|
$index_name or return $self->fatal(BADARGS => '$obj->drop_index(INDEX_NAME)');
|
|
exists $self->{table}->index->{$index_name} or return $self->warn(NOINDEX => $index_name);
|
|
|
|
# Check for conflicts
|
|
delete $self->{table}->index->{$index_name};
|
|
$self->{table}->check_schema or return $self->{table}->reset;
|
|
|
|
# Make the changes
|
|
my $table = $self->{table}->name;
|
|
$self->{table}->{driver}->drop_index($table, $index_name) or return $self->{table}->reset;
|
|
$self->{mods}->{$table} = $self->{table};
|
|
$self->save_state;
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->add_unique($index_name => [ field1, field2 .. ]);
|
|
# --------------------
|
|
# Add a unique index to the table specified by
|
|
# $index_name. The array should contain fields
|
|
# that will be part of the index.
|
|
##
|
|
$COMPILE{add_unique} = __LINE__ . <<'END_OF_SUB';
|
|
sub add_unique {
|
|
my ($self, $index_name, $indexes) = @_;
|
|
|
|
$index_name and ref $indexes eq 'ARRAY' or return $self->fatal(BADARGS => '$obj->add_unique(INDEX_NAME => ARRAY_REF)');
|
|
# Do the columns exist?
|
|
for (@$indexes) {
|
|
exists $self->{table}->cols->{$_} or return $self->warn(NOCOL => $_);
|
|
}
|
|
exists $self->{table}->unique->{$index_name} and return $self->warn(INDXEXISTS => $index_name);
|
|
|
|
my $table = $self->{table}->name;
|
|
|
|
# Do the new fields have unique data in them?
|
|
my $in = join ", " => @{$indexes};
|
|
my $query = "SELECT $in, COUNT(*) AS hits FROM $table GROUP BY $in HAVING ";
|
|
$query .= lc $self->{table}->{connect}->{driver} eq 'mysql' ? 'hits' : 'COUNT(*)';
|
|
$query .= ' > 1';
|
|
$self->debug($query) if $self->{_debug};
|
|
|
|
my $sth = $self->{table}->do($query) or return;
|
|
$sth->fetchrow and return $self->warn(NOTUNIQUE => $index_name);
|
|
|
|
# Check for conflicts
|
|
$self->{table}->unique->{$index_name} = $indexes;
|
|
$self->{table}->check_schema or return $self->{table}->reset;
|
|
|
|
# Make the changes
|
|
$self->{table}->{driver}->create_unique($table, $index_name, @$indexes) or return $self->{table}->reset;
|
|
$self->{mods}->{$table} = $self->{table};
|
|
$self->save_state;
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->drop_unique($index_name);
|
|
# --------------------------------
|
|
# Drops an index by the name $index_name.
|
|
##
|
|
$COMPILE{drop_unique} = __LINE__ . <<'END_OF_SUB';
|
|
sub drop_unique {
|
|
my ($self, $index_name) = @_;
|
|
|
|
$index_name or return $self->fatal(BADARGS => '$obj->drop_unique(INDEX_NAME)');
|
|
exists $self->{table}->unique->{$index_name} or return $self->warn(NOUNIQUE => $index_name);
|
|
|
|
my $table = $self->{table}->name;
|
|
|
|
# Check for conflicts
|
|
delete $self->{table}->unique->{$index_name};
|
|
$self->{table}->check_schema or return $self->{table}->reset;
|
|
|
|
# Make the changes
|
|
$self->{table}->{driver}->drop_index($table, $index_name) or return $self->{table}->reset;
|
|
$self->{mods}->{$table} = $self->{table};
|
|
$self->save_state;
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->add_pk($field1, $field2, ...);
|
|
# -------------------------------------
|
|
# Addes primary keys specified by list. If there is already a primary key it
|
|
# drops it and adds all the keys at the same time. If there is no primary
|
|
# keys this makes sure the data in the primary keys is unique.
|
|
##
|
|
$COMPILE{add_pk} = __LINE__ . <<'END_OF_SUB';
|
|
sub add_pk {
|
|
my ($self, @fields) = @_;
|
|
|
|
@fields or return $self->fatal(BADARGS => '$obj->add_pk(COLUMN1, COLUMN2, ...)');
|
|
for (@fields) {
|
|
exists $self->{table}->cols->{$_} or return $self->warn(NOCOL => $_);
|
|
}
|
|
|
|
my ($table, %add) = $self->{table}->name;
|
|
if ($self->{table}->pk) {
|
|
$self->{table}->{driver}->drop_pk($table) or return;
|
|
%add = map { $_ => 1 } @{delete $self->{table}->{schema}->{pk}};
|
|
}
|
|
|
|
# Check for conflicts
|
|
for (@fields) { $add{$_} = 1 }
|
|
$self->{table}->{schema}->{pk} = [keys %add];
|
|
$self->{table}->check_schema or return $self->{table}->reset;
|
|
|
|
# Make the changes
|
|
$self->{table}->{driver}->create_pk($table, keys %add) or return $self->{table}->reset;
|
|
$self->{mods}->{$table} = $self->{table};
|
|
$self->save_state;
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->drop_pk;
|
|
# --------------
|
|
# Drops the current primary key.
|
|
##
|
|
$COMPILE{drop_pk} = __LINE__ . <<'END_OF_SUB';
|
|
sub drop_pk {
|
|
my $self = shift;
|
|
$self->{table}->pk or return $self->warn('NOPK');
|
|
|
|
# Check for conflicts
|
|
$self->{table}->{schema}->{pk} = [];
|
|
$self->{table}->check_schema or return $self->{table}->reset;
|
|
|
|
# Make the changes
|
|
my $table = $self->{table}->name;
|
|
$self->{table}->{driver}->drop_pk($table) or return $self->{table}->reset;
|
|
$self->{mods}->{$table} = $self->{table};
|
|
$self->save_state;
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->add_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.
|
|
##
|
|
$COMPILE{add_fk} = __LINE__ . <<'END_OF_SUB';
|
|
sub add_fk {
|
|
my $self = shift;
|
|
$self->{table}->fk(@_) or return;
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->drop_fk(RELATION_NAME [, SKIPSAVE]);
|
|
# ---------------------------------------------
|
|
# Drops the foreign key relation for a given relation. If a second parameter
|
|
# is passed, and true, the state of the current table will not be saved (any
|
|
# other changed tables are, however).
|
|
##
|
|
$COMPILE{drop_fk} = __LINE__ . <<'END_OF_SUB';
|
|
sub drop_fk {
|
|
my ($self, $tbl, $nosave) = @_;
|
|
my $table = $self->{connect}->{PREFIX} . $tbl;
|
|
delete $self->{table}->{schema}->{fk}->{$table}
|
|
or return $self->warn(FKNOEXISTS => $tbl, $self->{table}->{name});
|
|
my $remote = $self->new_table($table);
|
|
my $rfk = $remote->fk_tables || [];
|
|
$remote->fk_tables([grep $_ ne $self->{table}->{name}, @$rfk]);
|
|
$remote->save_state;
|
|
$self->{table}->save_state unless $nosave;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->add_tree(ARGS);
|
|
# ---------------------
|
|
# Create a tree table for the current table.
|
|
# 'ARGS' is a hash or hash reference consisting of the following:
|
|
# father => 'father_id_column',
|
|
# root => 'root_id_column',
|
|
# depth => 'depth_column'
|
|
# where 'father_id_column', 'root_id_column', and 'depth_column' are the names
|
|
# of the columns you will use for keeping track of the father record, root
|
|
# record, and the depth from the root record, respectively. All of these
|
|
# columns should already exist - an error will occur if they do not.
|
|
#
|
|
# Any other arguments passed in will be passed straight through to
|
|
# GT::SQL::Tree->create
|
|
##
|
|
$COMPILE{add_tree} = __LINE__ . <<'END_OF_SUB';
|
|
sub add_tree {
|
|
my $self = shift;
|
|
|
|
my $input = $self->common_param(@_) or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(HASH or HASH REF)');
|
|
|
|
return $self->warn(TREEEXISTS => $self->{table}->{name}) if $self->{table}->{schema}->{tree} and ($input->{force} || 'force') eq 'check';
|
|
|
|
$input->{father} or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(..., father => \'father_col\', ...)');
|
|
$input->{root} or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(..., root => \'root_col\', ...)');
|
|
$input->{depth} or return $self->fatal(BADARGS => 'GT::SQL::Editor->add_tree(..., depth => \'depth_col\', ...)');
|
|
|
|
require GT::SQL::Tree;
|
|
GT::SQL::Tree->create(debug => $self->{_debug}, %$input, table => $self->{table});
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{drop_tree} = __LINE__ . <<'END_OF_SUB';
|
|
sub drop_tree {
|
|
my $self = shift;
|
|
my $tree = $self->{table}->tree or return;
|
|
$tree->destroy;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{load_data} = __LINE__ . <<'END_OF_SUB';
|
|
sub load_data {
|
|
# ---------------------------------------------------------------
|
|
# imports the contents of a file with validation.
|
|
#
|
|
my ($self, $file, $options) = @_;
|
|
-f $file and -r _ or return $self->fatal(FILENOEXISTS => $file);
|
|
$self->{table}->connect or return;
|
|
|
|
my $delim = $options->{delim} || '|';
|
|
my @cols = ref $options->{cols} ? @{$options->{cols}} : @{$self->{table}->ordered_columns};
|
|
|
|
local *FILE;
|
|
open FILE, $file or return $self->warn(CANTOPEN => $file, "$!");
|
|
while (<FILE>) {
|
|
chomp;
|
|
my $i = 0;
|
|
my %fields = map { $cols[$i++] => $_ } split /(?<!\\)\Q$delim\E/;
|
|
$self->{table}->insert(\%fields, 1) or print "Line $. skipped - validation failed:\n$GT::SQL::error\n\n";
|
|
}
|
|
close FILE;
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{export_data} = __LINE__ . <<'END_OF_SUB';
|
|
sub export_data {
|
|
# ---------------------------------------------------------------
|
|
# Dumps the contents of a table to a file.
|
|
#
|
|
my $self = shift;
|
|
my $opt = shift;
|
|
ref $opt eq 'HASH' or return $self->fatal(BADARGS => '$obj->export_data(HASHREF)');
|
|
|
|
my $order = $opt->{order};
|
|
my $delim = $opt->{delim} || '|';
|
|
my $file = $opt->{file} || undef;
|
|
my $header = $opt->{header} || undef;
|
|
my $table = $self->{table}->name;
|
|
|
|
my @order = $order
|
|
? ref $order eq 'ARRAY' ? @$order : $order
|
|
: $self->{table}->ordered_columns;
|
|
|
|
my ($offset, $limit) = (0, 1000);
|
|
|
|
local *FILE;
|
|
if ($file) {
|
|
open FILE, "> $file" or return $self->warn(CANTOPEN => $file, "$!");
|
|
}
|
|
while () {
|
|
$self->{table}->select_options("LIMIT $limit OFFSET " . ($offset++ * $limit));
|
|
my $sth = $self->{table}->select(\@order);
|
|
|
|
if ($header) {
|
|
print FILE join($delim, @order), "\n";
|
|
$header = undef;
|
|
}
|
|
my $count = 0;
|
|
while (my $arr = $sth->fetchrow_arrayref) {
|
|
++$count;
|
|
for (@$arr) {
|
|
y/\r//d;
|
|
s/\Q$delim\E/``/g;
|
|
s/\n/~~/g;
|
|
}
|
|
my $joined = join $delim, @$arr;
|
|
$file
|
|
? print FILE $joined, "\n"
|
|
: print $joined, "\n";
|
|
}
|
|
last unless $count;
|
|
}
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->drop_search_driver
|
|
# -----------------
|
|
# Drops current search driver
|
|
##
|
|
$COMPILE{drop_search_driver} = __LINE__ . <<'END_OF_SUB';
|
|
sub drop_search_driver {
|
|
my $self = shift;
|
|
|
|
require GT::SQL::Search;
|
|
if ($self->{table}->search_driver) {
|
|
my $indexer = GT::SQL::Search->load_indexer(table => $self->{table}, _debug => $self->{_debug}) or return;
|
|
$indexer->drop_search_driver or return;
|
|
}
|
|
$self->{table}->search_driver('NONINDEXED');
|
|
$self->{table}->save_state;
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->add_search_driver
|
|
# -----------------
|
|
# Adds new search driver
|
|
##
|
|
$COMPILE{add_search_driver} = __LINE__ . <<'END_OF_SUB';
|
|
sub add_search_driver {
|
|
my $self = shift;
|
|
my $olddriver = $self->{table}->search_driver();
|
|
my $newdriver = shift or return;
|
|
|
|
require GT::SQL::Search;
|
|
|
|
# check and see if driver is ok
|
|
GT::SQL::Search->driver_ok($newdriver, { table => $self->{table} }) or return;
|
|
|
|
# load the driver
|
|
my $indexer = GT::SQL::Search->load_indexer(table => $self->{table}, _debug => $self->{_debug}, driver => $newdriver) or return;
|
|
$indexer->add_search_driver or return;
|
|
|
|
$self->{table}->search_driver($newdriver);
|
|
$self->{table}->save_state or return;
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
##
|
|
# $obj->change_search_driver
|
|
# -----------------
|
|
# Adds new search driver
|
|
##
|
|
$COMPILE{change_search_driver} = __LINE__ . <<'END_OF_SUB';
|
|
sub change_search_driver {
|
|
my $self = shift;
|
|
my $newdriver = uc shift or return;
|
|
my $driver = $self->{table}->search_driver;
|
|
$driver eq $newdriver and return $self->warn(SAMEDRIVER => $driver);
|
|
|
|
$self->drop_search_driver() or return;
|
|
$self->add_search_driver($newdriver) or 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;
|
|
my $rm_fk = lc(shift or '') eq 'remove';
|
|
my $table = $self->{table}->name;
|
|
my $tmp = $self->{table}->fk_tables() || [];
|
|
@$tmp and !$rm_fk and return $self->warn(TABLEREFD => $table);
|
|
|
|
my $tmp_weights = {};
|
|
if ($self->_uses_weights) {
|
|
$tmp_weights = $self->_get_indexer->pre_drop_table() or return
|
|
}
|
|
|
|
$self->{table}->{driver}->drop_table($table) or return;
|
|
|
|
delete $GT::SQL::OBJ_CACHE{"TABLE\0$table\0$self->{connect}->{def_path}"};
|
|
|
|
# If this table has a tree, drop it:
|
|
$self->drop_tree if $self->{table}->{schema}->{tree};
|
|
|
|
unlink "$self->{connect}->{def_path}/$table.def";
|
|
|
|
for (keys %{$self->{table}->{schema}->{fk}}) {
|
|
next if $_ eq $table;
|
|
my $t = $self->new_table($_);
|
|
$t->{schema}->{fk_tables} = [grep $_ ne $table, @{$t->{schema}->{fk_tables}}];
|
|
$t->save_state();
|
|
}
|
|
|
|
$self->_file_drop_tables();
|
|
$self->_uses_weights and ($self->_get_indexer->post_drop_table($tmp_weights) or return);
|
|
$rm_fk and $self->_drop_related_fk_entries($table);
|
|
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_file_drop_tables} = __LINE__ . <<'END_OF_SUB';
|
|
sub _file_drop_tables {
|
|
my $self = shift;
|
|
if ( $self->{table}->_file_cols() ) {
|
|
require GT::SQL::File;
|
|
GT::SQL::File->new({ parent_table => $self->{table}, connect => $self->{connect} })->drop_table();
|
|
}
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_drop_related_fk_entries} = __LINE__ . <<'END_OF_SUB';
|
|
sub _drop_related_fk_entries {
|
|
my $self = shift;
|
|
my $table_name = shift or return;
|
|
|
|
my $fk = $self->{table}->fk() or return;
|
|
my $prefix = $self->{connect}->{PREFIX};
|
|
for my $related_name ( keys %{$fk} ) {
|
|
my $table = $self->{table}->new_table($related_name);
|
|
my $fk_tables = $table->fk_tables() or next;
|
|
$fk_tables = [ grep { $_ ne $table_name } @{$fk_tables} ];
|
|
$table->fk_tables( $fk_tables );
|
|
$table->save_state();
|
|
}
|
|
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
###########################################################################
|
|
##### Private Functions #####
|
|
###########################################################################
|
|
|
|
$COMPILE{_is_referenced} = __LINE__ . <<'END_OF_SUB';
|
|
sub _is_referenced {
|
|
my ($self, $mytable, $mycol) = @_;
|
|
for my $table (@{$self->{table}->fk_tables}) {
|
|
my $fk = $self->new_table($table)->fk;
|
|
if (exists $fk->{$mytable}) {
|
|
for my $key (keys %{$fk->{$mytable}}) {
|
|
if ($mycol eq $fk->{$mytable}->{$key}) {
|
|
return 1;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
0;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_remove_referenced} = __LINE__ . <<'END_OF_SUB';
|
|
sub _remove_referenced {
|
|
my ($self, $mytable, $mycol) = @_;
|
|
for my $table (@{$self->{table}->fk_tables}) {
|
|
my $new_table = $self->{mods}->{$table} || $self->new_table($table);
|
|
my $fk = $new_table->fk;
|
|
if (exists $fk->{$mytable}) {
|
|
for my $key (keys %{$fk->{$mytable}}) {
|
|
if ($mycol eq $fk->{$mytable}->{$key}) {
|
|
delete $fk->{$mytable}->{$key};
|
|
$self->{mods}->{$table} ||= $new_table;
|
|
}
|
|
if (not keys %{$fk->{$mytable}}) {
|
|
delete $fk->{$mytable};
|
|
$self->{mods}->{$table} ||= $new_table;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
$COMPILE{_remove_references} = __LINE__ . <<'END_OF_SUB';
|
|
sub _remove_references {
|
|
my ($self, $mytable, $mycol) = @_;
|
|
for my $table (keys %{$self->{table}->fk}) {
|
|
if ($self->{table}->fk->{$table}->{$mycol}) {
|
|
delete $self->{table}->fk->{$table}->{$mycol};
|
|
}
|
|
next if keys %{$self->{table}->fk->{$table}};
|
|
my $t = $self->{mods}->{$table} || $self->new_table($table);
|
|
$t->{schema}->{fk_table} = [grep $_ ne $mytable, @{$t->fk_tables}];
|
|
$self->{mods}->{$table} = $t;
|
|
}
|
|
1;
|
|
}
|
|
END_OF_SUB
|
|
|
|
sub save_state {
|
|
my $self = shift;
|
|
for my $table (keys %{$self->{mods}}) {
|
|
my $new_table = $self->{mods}->{$table};
|
|
$new_table->save_state or return;
|
|
delete $self->{mods}->{$new_table};
|
|
}
|
|
1;
|
|
}
|
|
|
|
sub _uses_weights {
|
|
#-------------------------------------------------------------------------------
|
|
return keys %{$_[0]->{table}->weight()}
|
|
}
|
|
|
|
$COMPILE{_get_indexer} = __LINE__ . <<'END_OF_SUB';
|
|
sub _get_indexer {
|
|
#-------------------------------------------------------------------------------
|
|
my $self = shift;
|
|
require GT::SQL::Search;
|
|
my $indexer = GT::SQL::Search->load_indexer(
|
|
table => $self->{table},
|
|
debug => $self->{_debug}
|
|
);
|
|
return $indexer;
|
|
}
|
|
END_OF_SUB
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::SQL::Editor - an interface to modify an SQL table.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
my $editor = $DB->editor('Table');
|
|
$editor->add_col(Foo => { size => 20, type => 'int' });
|
|
$editor->export_data('/tmp/foo.txt');
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
GT::SQL::Editor is an easy way to do a lot of table maintenance
|
|
functions like:
|
|
|
|
* Adding columns
|
|
* Dropping columns
|
|
* Changing columns
|
|
* Altering keys
|
|
* Importing data
|
|
* Dropping data
|
|
|
|
To get an editor object, you simply call C<editor> from a
|
|
GT::SQL object, and specify the tablename you want to edit:
|
|
|
|
$editor = $db->editor('TableName');
|
|
|
|
Note: You can not use Editor with relations, only tables.
|
|
|
|
=head2 add_col
|
|
|
|
This method allows you to add a column to the current table.
|
|
All attributes for the column are passed in a single hash.
|
|
|
|
$editor->add_col($col_name,
|
|
{
|
|
size => 20,
|
|
type => 'int',
|
|
view_size => 20,
|
|
form_display => "my col",
|
|
regex => 'myregex'
|
|
}
|
|
);
|
|
|
|
The same rules apply to this method that apply when you
|
|
define a column for creating a table. You must specify the
|
|
type.
|
|
|
|
=head2 drop_col
|
|
|
|
This method drops a column from the current table. Checks
|
|
are made to ensure the column is not linked to by a foreign
|
|
key relation.
|
|
|
|
$editor->drop_col($col_name);
|
|
|
|
-or-
|
|
|
|
$editor->drop_col($col_name, "remove");
|
|
|
|
If you just specify the column name C<drop_col> will check if
|
|
the column is referenced in a foreign key relation. If it
|
|
is C<drop_col> will return undef and set the error message in
|
|
$GT::SQL::error. If it is not the column will be dropped.
|
|
|
|
If you specify "remove" C<drop_col> will remove all foreign
|
|
key relations that point to the specified column.
|
|
|
|
If the specified column is itself a foreign key relation, the relation will be
|
|
dropped.
|
|
|
|
=head2 alter_col
|
|
|
|
This allows you to make changes to a columns type, null status,
|
|
etc..
|
|
|
|
$editor->alter_col($column_name,
|
|
{
|
|
size => 20,
|
|
type => 'int'
|
|
});
|
|
|
|
The first argument is the column name the second is the definitions.
|
|
The column definitions are exactly the same as the column
|
|
definitions from the create. The type must be specified.
|
|
|
|
You can not add attributes to the column in this way.
|
|
You must specify the original definitions along with the
|
|
changes you need to make.
|
|
|
|
=head2 add_unique
|
|
|
|
This allows you to add a unique index to the current table.
|
|
If the name of the unique index is the same as another
|
|
index you C<add_unique> will return undef and set the error
|
|
in $GT::SQL::error.
|
|
|
|
$editor->add_unique($index_name => [ $field1, $field2 .. ]);
|
|
|
|
The name of the new index is the first argument. The second argument
|
|
is an array reference containing the columns that will be indexed.
|
|
The order of the columns are maintained for the unique index.
|
|
If you specify an index that has data in it that is not unique
|
|
(yes we do a select on the database) C<add_unique> will return
|
|
an error and set the error in $GT::SQL::error.
|
|
|
|
=head2 drop_unique
|
|
|
|
This method allows you to drop a unique index for the current
|
|
table. If the unique index does not exist C<drop_unique> will
|
|
return undef and set the error in $GT::SQL::error. C<drop_unique>
|
|
will also check to make sure dropping the unique index will not
|
|
cause problems for the database structure. If dropping the unique
|
|
index will cause a problem C<drop_unique> will return undef and set
|
|
the error in $GT::SQL::error.
|
|
|
|
$editor->drop_unique($index_name);
|
|
|
|
$index_name should be the name of the unique index to drop.
|
|
|
|
=head2 add_index
|
|
|
|
This takes the same arguments as C<add_unique> and return the same thing.
|
|
The only difference is C<add_index> has no reason to check the content of
|
|
the current table because indexes are not unique. unique indexes are :)
|
|
|
|
$editor->add_index($index_name => [ $field1, $field2 .. ]);
|
|
|
|
=head2 drop_index
|
|
|
|
This method drops the specified index from the current table.
|
|
C<drop_index> will check to make sure no problems are caused from
|
|
dropping the index. If there are C<drop_index> will return undef
|
|
and set the error in $GT::SQL::error.
|
|
|
|
$editor->drop_index($index_name);
|
|
|
|
$index_name should be the name of the index to drop.
|
|
|
|
=head2 add_pk
|
|
|
|
This method allows you to add a primary key to the current
|
|
database.
|
|
|
|
$editor->add_pk($field1, $field2, ...);
|
|
|
|
If there is already a primary key in the database C<add_pk>
|
|
will drop the key and add the this new one. The table
|
|
will be check to make sure this change does not create problems
|
|
for the table. I problem is auto increment not being the primary
|
|
key anymore. If there is a problem this function returns undef
|
|
and stores the error in $GT::SQL::error.
|
|
|
|
=head2 drop_pk
|
|
|
|
This method drops the current primary key. If there is no primary
|
|
key to drop it returns undef and sets the error in $GT::SQL::error.
|
|
|
|
$editor->drop_pk;
|
|
|
|
If dropping the primary key will cause problems for the database
|
|
this method will return undef and set the error in $GT::SQL::error.
|
|
|
|
=head2 add_fk
|
|
|
|
This method allows you to add foreign key relations to the current
|
|
table.
|
|
|
|
$editor->add_fk($RELATION_NAME, { $SOURCE_FIELD_1 => $TARGET_FIELD });
|
|
|
|
You can not link your foreign key to tables that do not exist. Also the
|
|
columns types and lengths for the two columns must be the same.
|
|
Circularity is not allowed either. That is a set of foreign keys can not
|
|
end up pointing back at the same table they started at. All of these things
|
|
are checked when this is added. If anything does not match this method returns
|
|
undef and sets the error in $GT::SQL::error.
|
|
|
|
=head2 drop_fk
|
|
|
|
This method drops the specified foreign key relation.
|
|
|
|
$editor->drop_fk($table);
|
|
|
|
$table should be the name of the foreign table the foreign
|
|
key points to.
|
|
|
|
=head2 drop_table
|
|
|
|
This method drops the current table. If there are any foreign keys
|
|
pointing to this table this method will fail and return undef. The error
|
|
will be set in $GT::SQL::error.
|
|
|
|
$editor->drop_table;
|
|
|
|
-or-
|
|
|
|
$editor->drop_table("remove");
|
|
|
|
If the first argument to this method is remove it will remove all
|
|
the foreign key relations that point to this table.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: Editor.pm,v 1.79 2007/09/05 04:42:31 brewt Exp $
|
|
|
|
=cut
|