package SQL::Translator::Schema;
# ----------------------------------------------------------------------
-# $Id: Schema.pm,v 1.20 2004-11-05 13:19:31 grommit Exp $
+# $Id: Schema.pm,v 1.21 2004-11-27 16:32:16 schiffbruechige Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use base 'SQL::Translator::Schema::Object';
use vars qw[ $VERSION $TABLE_ORDER $VIEW_ORDER $TRIGGER_ORDER $PROC_ORDER ];
-$VERSION = sprintf "%d.%02d", q$Revision: 1.20 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.21 $ =~ /(\d+)\.(\d+)/;
# ----------------------------------------------------------------------
}
# ----------------------------------------------------------------------
+sub drop_table {
+
+=pod
+
+=head2 drop_table
+
+Remove a table from the schema. Returns the table object if the table was found
+and removed, an error otherwise. The single parameter can be either a table
+name or an C<SQL::Translator::Schema::Table> object. The "cascade" parameter
+can be set to 1 to also drop all triggers on the table, default is 0.
+
+ $schema->drop_table('mytable');
+ $schema->drop_table('mytable', cascade => 1);
+
+=cut
+
+ my $self = shift;
+ my $table_class = 'SQL::Translator::Schema::Table';
+ my $table_name;
+
+ if ( UNIVERSAL::isa( $_[0], $table_class ) ) {
+ $table_name = shift->name;
+ }
+ else {
+ $table_name = shift;
+ }
+ my %args = @_;
+ my $cascade = $args{'cascade'};
+
+ if ( ! exists $self->{'tables'}{ $table_name } ) {
+ return $self->error(qq[Can't drop table: $table_name" doesn't exist]);
+ }
+
+ my $table = delete $self->{'tables'}{ $table_name };
+
+ if ( $cascade ) {
+ # Drop all triggers on this table
+ $self->drop_trigger() for (grep { $_->on_table eq $table_name }
+ @{ $self->{'triggers'}}
+ );
+ }
+ return $table;
+}
+
+# ----------------------------------------------------------------------
sub add_procedure {
=pod
=head2 add_procedure
-Add a procedure object. Returns the new
-SQL::Translator::Schema::Procedure object. The "name" parameter is
-required. If you try to create a procedure with the same name as an
-existing procedure, you will get an error and the procedure will not
-be created.
+Add a procedure object. Returns the new SQL::Translator::Schema::Procedure
+object. The "name" parameter is required. If you try to create a procedure
+with the same name as an existing procedure, you will get an error and the
+procedure will not be created.
my $p1 = $schema->add_procedure( name => 'foo' );
my $p2 = SQL::Translator::Schema::Procedure->new( name => 'bar' );
return $procedure;
}
+# ----------------------------------------------------------------------
+sub drop_procedure {
+
+=pod
+
+=head2 drop_procedure
+
+Remove a procedure from the schema. Returns the procedure object if the
+procedure was found and removed, an error otherwise. The single parameter
+can be either a procedure name or an C<SQL::Translator::Schema::Procedure>
+object.
+
+ $schema->drop_procedure('myprocedure');
+
+=cut
+
+ my $self = shift;
+ my $proc_class = 'SQL::Translator::Schema::Procedure';
+ my $proc_name;
+
+ if ( UNIVERSAL::isa( $_[0], $proc_class ) ) {
+ $proc_name = shift->name;
+ }
+ else {
+ $proc_name = shift;
+ }
+
+ if ( ! exists $self->{'procedures'}{ $proc_name } ) {
+ return $self->error(qq[Can't drop procedure: $proc_name" doesn't exist]);
+ }
+
+ my $proc = delete $self->{'procedures'}{ $proc_name };
+
+ return $proc;
+}
# ----------------------------------------------------------------------
sub add_trigger {
return $trigger;
}
+# ----------------------------------------------------------------------
+sub drop_trigger {
+
+=pod
+
+=head2 drop_trigger
+
+Remove a trigger from the schema. Returns the trigger object if the trigger was
+found and removed, an error otherwise. The single parameter can be either a
+trigger name or an C<SQL::Translator::Schema::Trigger> object.
+
+ $schema->drop_trigger('mytrigger');
+
+=cut
+
+ my $self = shift;
+ my $trigger_class = 'SQL::Translator::Schema::Trigger';
+ my $trigger_name;
+
+ if ( UNIVERSAL::isa( $_[0], $trigger_class ) ) {
+ $trigger_name = shift->name;
+ }
+ else {
+ $trigger_name = shift;
+ }
+
+ if ( ! exists $self->{'triggers'}{ $trigger_name } ) {
+ return $self->error(qq[Can't drop trigger: $trigger_name" doesn't exist]);
+ }
+
+ my $trigger = delete $self->{'triggers'}{ $trigger_name };
+
+ return $trigger;
+}
# ----------------------------------------------------------------------
sub add_view {
}
# ----------------------------------------------------------------------
+sub drop_view {
+
+=pod
+
+=head2 drop_view
+
+Remove a view from the schema. Returns the view object if the view was found
+and removed, an error otherwise. The single parameter can be either a view
+name or an C<SQL::Translator::Schema::View> object.
+
+ $schema->drop_view('myview');
+
+=cut
+
+ my $self = shift;
+ my $view_class = 'SQL::Translator::Schema::View';
+ my $view_name;
+
+ if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
+ $view_name = shift->name;
+ }
+ else {
+ $view_name = shift;
+ }
+
+ if ( ! exists $self->{'views'}{ $view_name } ) {
+ return $self->error(qq[Can't drop view: $view_name" doesn't exist]);
+ }
+
+ my $view = delete $self->{'views'}{ $view_name };
+
+ return $view;
+}
+
+# ----------------------------------------------------------------------
sub database {
=pod
=over 4
-=item * join_pk_only
+=item * join_pk_only
A True or False argument which determins whether or not to perform
the joins from primary keys to fields of the same name in other tables
reference_table => $table2->name,
reference_fields => $field,
);
- }
+ }
}
- }
+ }
return 1;
}
package SQL::Translator::Schema::Table;
# ----------------------------------------------------------------------
-# $Id: Table.pm,v 1.29 2004-11-05 15:03:10 grommit Exp $
+# $Id: Table.pm,v 1.30 2004-11-27 16:32:46 schiffbruechige Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use vars qw( $VERSION $FIELD_ORDER );
-$VERSION = sprintf "%d.%02d", q$Revision: 1.29 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/;
# Stringify to our name, being careful not to pass any args through so we don't
}
# ----------------------------------------------------------------------
+sub drop_constraint {
+
+=pod
+
+=head2 drop_constraint
+
+Remove a constraint from the table. Returns the constraint object if the index
+was found and removed, an error otherwise. The single parameter can be either
+an index name or an C<SQL::Translator::Schema::Constraint> object.
+
+ $table->drop_constraint('myconstraint');
+
+=cut
+
+ my $self = shift;
+ my $constraint_class = 'SQL::Translator::Schema::Constraint';
+ my $constraint_name;
+
+ if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
+ $constraint_name = shift->name;
+ }
+ else {
+ $constraint_name = shift;
+ }
+
+ if ( ! grep { $_->name eq $constraint_name } @ { $self->{'constraints'} } ) {
+ return $self->error(qq[Can't drop constraint: "$constraint_name" doesn't exist]);
+ }
+
+ my @cs = @{ $self->{'constraints'} };
+ my ($constraint_id) = grep { $cs[$_]->name eq $constraint_name } (0..$#cs);
+ my $constraint = splice(@{$self->{'constraints'}}, $constraint_id, 1);
+
+ return $constraint;
+}
+
+# ----------------------------------------------------------------------
sub add_index {
=pod
}
# ----------------------------------------------------------------------
+sub drop_index {
+
+=pod
+
+=head2 drop_index
+
+Remove an index from the table. Returns the index object if the index was
+found and removed, an error otherwise. The single parameter can be either
+an index name of an C<SQL::Translator::Schema::Index> object.
+
+ $table->drop_index('myindex');
+
+=cut
+
+ my $self = shift;
+ my $index_class = 'SQL::Translator::Schema::Index';
+ my $index_name;
+
+ if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
+ $index_name = shift->name;
+ }
+ else {
+ $index_name = shift;
+ }
+
+ if ( ! grep { $_->name eq $index_name } @{ $self->{'indices'} }) {
+ return $self->error(qq[Can't drop index: "$index_name" doesn't exist]);
+ }
+
+ my @is = @{ $self->{'indices'} };
+ my ($index_id) = grep { $is[$_]->name eq $index_name } (0..$#is);
+ my $index = splice(@{$self->{'indices'}}, $index_id, 1);
+
+ return $index;
+}
+
+# ----------------------------------------------------------------------
sub add_field {
=pod
return $field;
}
+# ----------------------------------------------------------------------
+sub drop_field {
+
+=pod
+
+=head2 drop_field
+
+Remove a field from the table. Returns the field object if the field was
+found and removed, an error otherwise. The single parameter can be either
+a field name or an C<SQL::Translator::Schema::Field> object.
+
+ $table->drop_field('myfield');
+
+=cut
+
+ my $self = shift;
+ my $field_class = 'SQL::Translator::Schema::Field';
+ my $field_name;
+
+ if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
+ $field_name = shift->name;
+ }
+ else {
+ $field_name = shift;
+ }
+ my %args = @_;
+ my $cascade = $args{'cascade'};
+
+ if ( ! exists $self->{'fields'}{ $field_name } ) {
+ return $self->error(qq[Can't drop field: "$field_name" doesn't exists]);
+ }
+
+ my $field = delete $self->{'fields'}{ $field_name };
+
+ if ( $cascade ) {
+ # Remove this field from all indices using it
+ foreach my $i ($self->get_indices()) {
+ my @fs = $i->fields();
+ @fs = grep { $_ ne $field->name } @fs;
+ $i->fields(@fs);
+ }
+
+ # Remove this field from all constraints using it
+ foreach my $c ($self->get_constraints()) {
+ my @cs = $c->fields();
+ @cs = grep { $_ ne $field->name } @cs;
+ $c->fields(@cs);
+ }
+ }
+
+ return $field;
+}
# ----------------------------------------------------------------------
sub comments {
$| = 1;
use strict;
-use Test::More tests => 206;
+use Test::More tests => 232;
use SQL::Translator::Schema::Constants;
require_ok( 'SQL::Translator' );
'... because "foo" exists' );
$redundant_table = $schema->add_table(name => '');
- is( $redundant_table, undef, qq[Can't add an anonymouse table...] );
+ is( $redundant_table, undef, qq[Can't add an anonymous table...] );
like( $schema->error, qr/No table name/i,
- '... because if has no name ' );
+ '... because it has no name ' );
$redundant_table = SQL::Translator::Schema::Table->new(name => '');
- is( $redundant_table, undef, qq[Can't create an anonymouse table] );
+ is( $redundant_table, undef, qq[Can't create an anonymous table] );
like( SQL::Translator::Schema::Table->error, qr/No table name/i,
- '... because if has no name ' );
+ '... because it has no name ' );
#
+ # $schema-> drop_table
+ #
+ my $dropped_table = $schema->drop_table($foo_table->name, cascade => 1);
+ isa_ok($dropped_table, 'SQL::Translator::Schema::Table', 'Dropped table "foo"' );
+ $schema->add_table($foo_table);
+ my $dropped_table2 = $schema->drop_table($foo_table, cascade => 1);
+ isa_ok($dropped_table2, 'SQL::Translator::Schema::Table', 'Dropped table "foo" by object' );
+ my $dropped_table3 = $schema->drop_table($foo_table->name, cascade => 1);
+ like( $schema->error, qr/doesn't exist/, qq[Can't drop non-existant table "foo"] );
+
+ $schema->add_table($foo_table);
+ #
# Table default new
#
is( $foo_table->name, 'foo', 'Table name is "foo"' );
'field_names is "foo,f2"' );
#
+ # $table-> drop_field
+ #
+ my $dropped_field = $person_table->drop_field($f2->name, cascade => 1);
+ isa_ok($dropped_field, 'SQL::Translator::Schema::Field', 'Dropped field "f2"' );
+ $person_table->add_field($f2);
+ my $dropped_field2 = $person_table->drop_field($f2, cascade => 1);
+ isa_ok($dropped_field2, 'SQL::Translator::Schema::Field', 'Dropped field "f2" by object' );
+ my $dropped_field3 = $person_table->drop_field($f2->name, cascade => 1);
+ like( $person_table->error, qr/doesn't exist/, qq[Can't drop non-existant field "f2"] );
+
+ $person_table->add_field($f2);
+
+ #
# Field methods
#
is( $f1->name('person_name'), 'person_name',
is( $indices->[1]->name, 'bar', '"bar" index' );
#
+ # $table-> drop_index
+ #
+ my $dropped_index = $person_table->drop_index($index1->name);
+ isa_ok($dropped_index, 'SQL::Translator::Schema::Index', 'Dropped index "foo"' );
+ $person_table->add_index($index1);
+ my $dropped_index2 = $person_table->drop_index($index1);
+ isa_ok($dropped_index2, 'SQL::Translator::Schema::Index', 'Dropped index "foo" by object' );
+ is($dropped_index2->name, $index1->name, 'Dropped correct index "foo"');
+ my $dropped_index3 = $person_table->drop_index($index1->name);
+ like( $person_table->error, qr/doesn't exist/, qq[Can't drop non-existant index "foo"] );
+
+ $person_table->add_index($index1);
+
+ #
# Constraint
#
my @constraints = $person_table->get_constraints;
is( $constraints->[1]->name, 'bar', '"bar" constraint' );
#
+ # $table-> drop_constraint
+ #
+ my $dropped_con = $person_table->drop_constraint($constraint1->name);
+ isa_ok($dropped_con, 'SQL::Translator::Schema::Constraint', 'Dropped constraint "foo"' );
+ $person_table->add_constraint($constraint1);
+ my $dropped_con2 = $person_table->drop_constraint($constraint1);
+ isa_ok($dropped_con2, 'SQL::Translator::Schema::Constraint', 'Dropped constraint "foo" by object' );
+ is($dropped_con2->name, $constraint1->name, 'Dropped correct constraint "foo"');
+ my $dropped_con3 = $person_table->drop_constraint($constraint1->name);
+ like( $person_table->error, qr/doesn't exist/, qq[Can't drop non-existant constraint "foo"] );
+
+ $person_table->add_constraint($constraint1);
+
+ #
# View
#
my $view = $schema->add_view( name => 'view1' ) or warn $schema->error;
like( $schema->error, qr/can't create view/i, '... because it exists' );
#
+ # $schema-> drop_view
+ #
+ my $dropped_view = $schema->drop_view($view->name);
+ isa_ok($dropped_view, 'SQL::Translator::Schema::View', 'Dropped view "view1"' );
+ $schema->add_view($view);
+ my $dropped_view2 = $schema->drop_view($view);
+ isa_ok($dropped_view2, 'SQL::Translator::Schema::View', 'Dropped view "view1" by object' );
+ is($dropped_view2->name, $view->name, 'Dropped correct view "view1"');
+ my $dropped_view3 = $schema->drop_view($view->name);
+ like( $schema->error, qr/doesn't exist/, qq[Can't drop non-existant view "view1"] );
+
+ $schema->add_view($view);
+
+ #
# $schema->get_*
#
my $bad_table = $schema->get_table;
my $t1 = $s->get_trigger( $name );
isa_ok( $t1, 'SQL::Translator::Schema::Trigger', 'Trigger' );
is( $t1->name, $name, qq[Name is "$name"] );
-}
+ #
+ # $schema-> drop_trigger
+ #
+ my $dropped_trig = $s->drop_trigger($t->name);
+ isa_ok($dropped_trig, 'SQL::Translator::Schema::Trigger', 'Dropped trigger "foo_trigger"' );
+ $s->add_trigger($t);
+ my $dropped_trig2 = $s->drop_trigger($t);
+ isa_ok($dropped_trig2, 'SQL::Translator::Schema::Trigger', 'Dropped trigger "foo_trigger" by object' );
+ is($dropped_trig2->name, $t->name, 'Dropped correct trigger "foo_trigger"');
+ my $dropped_trig3 = $s->drop_trigger($t->name);
+ like( $s->error, qr/doesn't exist/, qq[Can't drop non-existant trigger "foo_trigger"] );
+
+ $s->add_trigger($t);
+}
+
#
# Procedure
#
my $p1 = $s->get_procedure( $name );
isa_ok( $p1, 'SQL::Translator::Schema::Procedure', 'Procedure' );
is( $p1->name, $name, qq[Name is "$name"] );
+
+ #
+ # $schema-> drop_procedure
+ #
+ my $dropped_proc = $s->drop_procedure($p->name);
+ isa_ok($dropped_proc, 'SQL::Translator::Schema::Procedure', 'Dropped procedure "foo_proc"' );
+ $s->add_procedure($p);
+ my $dropped_proc2 = $s->drop_procedure($p);
+ isa_ok($dropped_proc2, 'SQL::Translator::Schema::Procedure', 'Dropped procedure "foo_proc" by object' );
+ is($dropped_proc2->name, $p->name, 'Dropped correct procedure "foo_proc"');
+ my $dropped_proc3 = $s->drop_procedure($p->name);
+ like( $s->error, qr/doesn't exist/, qq[Can't drop non-existant procedure "foo_proc"] );
+
+ $s->add_procedure($p);
}
projects / dbsrgits/SQL-Translator.git / commitdiff