X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FSchema%2FTable.pm;h=36c2c09e3f0f733dcd8f8c950dabfd1331f643f5;hb=4a9399ae2689294bac4d036f23c884dc1235b865;hp=64e3b831e7bb42a719e96842236ab606d7e3abf9;hpb=b6a880d1daac518c07475bad0c7ef74d0416386b;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Schema/Table.pm b/lib/SQL/Translator/Schema/Table.pm index 64e3b83..36c2c09 100644 --- a/lib/SQL/Translator/Schema/Table.pm +++ b/lib/SQL/Translator/Schema/Table.pm @@ -1,25 +1,5 @@ package SQL::Translator::Schema::Table; -# ---------------------------------------------------------------------- -# $Id: Table.pm,v 1.27 2004-11-04 16:29:56 grommit Exp $ -# ---------------------------------------------------------------------- -# Copyright (C) 2002-4 SQLFairy Authors -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License as -# published by the Free Software Foundation; version 2. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -# 02111-1307 USA -# ------------------------------------------------------------------- - =pod =head1 NAME @@ -31,7 +11,7 @@ SQL::Translator::Schema::Table - SQL::Translator table object use SQL::Translator::Schema::Table; my $table = SQL::Translator::Schema::Table->new( name => 'foo' ); -=head1 DESCSIPTION +=head1 DESCRIPTION C is the table object. @@ -40,19 +20,19 @@ C is the table object. =cut use strict; +use warnings; use SQL::Translator::Utils 'parse_list_arg'; use SQL::Translator::Schema::Constants; use SQL::Translator::Schema::Constraint; use SQL::Translator::Schema::Field; use SQL::Translator::Schema::Index; -use Data::Dumper; - -use base 'SQL::Translator::Schema::Object'; -use vars qw( $VERSION $FIELD_ORDER ); +use Carp::Clan '^SQL::Translator'; +use List::Util 'max'; -$VERSION = sprintf "%d.%02d", q$Revision: 1.27 $ =~ /(\d+)\.(\d+)/; +use base 'SQL::Translator::Schema::Object'; +our $VERSION = '1.59'; # Stringify to our name, being careful not to pass any args through so we don't # accidentally set it to undef. We also have to tweak bool so the object is @@ -63,8 +43,7 @@ use overload fallback => 1, ; -# ---------------------------------------------------------------------- -sub init { +__PACKAGE__->_attributes( qw/schema name comments options order/ ); =pod @@ -72,31 +51,20 @@ sub init { Object constructor. - my $table = SQL::Translator::Schema::Table->new( + my $table = SQL::Translator::Schema::Table->new( schema => $schema, name => 'foo', ); =cut - my ( $self, $config ) = @_; - - for my $arg ( qw[ schema name comments ] ) { - next unless defined $config->{ $arg }; - defined $self->$arg( $config->{ $arg } ) or return; - } - - return $self; -} - -# ---------------------------------------------------------------------- sub add_constraint { =pod =head2 add_constraint -Add a constraint to the table. Returns the newly created +Add a constraint to the table. Returns the newly created C object. my $c1 = $table->add_constraint( @@ -121,8 +89,8 @@ C object. else { my %args = @_; $args{'table'} = $self; - $constraint = $constraint_class->new( \%args ) or - return $self->error( $constraint_class->error ); + $constraint = $constraint_class->new( \%args ) or + return $self->error( $constraint_class->error ); } # @@ -133,6 +101,9 @@ C object. my $pk = $self->primary_key; if ( $pk && $constraint->type eq PRIMARY_KEY ) { $self->primary_key( $constraint->fields ); + $pk->name($constraint->name) if $constraint->name; + my %extra = $constraint->extra; + $pk->extra(%extra) if keys %extra; $constraint = $pk; $ok = 0; } @@ -144,20 +115,20 @@ C object. } } # - # See if another constraint of the same type + # See if another constraint of the same type # covers the same fields. -- This doesn't work! ky # # elsif ( $constraint->type ne CHECK_C ) { # my @field_names = $constraint->fields; -# for my $c ( -# grep { $_->type eq $constraint->type } -# $self->get_constraints +# for my $c ( +# grep { $_->type eq $constraint->type } +# $self->get_constraints # ) { # my %fields = map { $_, 1 } $c->fields; # for my $field_name ( @field_names ) { # if ( $fields{ $field_name } ) { # $constraint = $c; -# $ok = 0; +# $ok = 0; # last; # } # } @@ -172,7 +143,42 @@ C object. return $constraint; } -# ---------------------------------------------------------------------- +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 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 @@ -204,15 +210,52 @@ C object. else { my %args = @_; $args{'table'} = $self; - $index = $index_class->new( \%args ) or return + $index = $index_class->new( \%args ) or return $self->error( $index_class->error ); } - + foreach my $ex_index ($self->get_indices) { + return if ($ex_index->equals($index)); + } push @{ $self->{'indices'} }, $index; return $index; } -# ---------------------------------------------------------------------- +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 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 @@ -220,8 +263,8 @@ sub add_field { =head2 add_field Add an field to the table. Returns the newly created -C object. The "name" parameter is -required. If you try to create a field with the same name as an +C object. The "name" parameter is +required. If you try to create a field with the same name as an existing field, you will get an error and the field will not be created. my $f1 = $table->add_field( @@ -230,8 +273,8 @@ existing field, you will get an error and the field will not be created. size => 11, ); - my $f2 = SQL::Translator::Schema::Field->new( - name => 'name', + my $f2 = SQL::Translator::Schema::Field->new( + name => 'name', table => $table, ); $f2 = $table->add_field( $field2 ) or die $table->error; @@ -249,15 +292,39 @@ existing field, you will get an error and the field will not be created. else { my %args = @_; $args{'table'} = $self; - $field = $field_class->new( \%args ) or return + $field = $field_class->new( \%args ) or return $self->error( $field_class->error ); } - $field->order( ++$FIELD_ORDER ); + my $existing_order = { map { $_->order => $_->name } $self->get_fields }; + + # supplied order, possible unordered assembly + if ( $field->order ) { + if($existing_order->{$field->order}) { + croak sprintf + "Requested order '%d' for column '%s' conflicts with already existing column '%s'", + $field->order, + $field->name, + $existing_order->{$field->order}, + ; + } + } + else { + my $last_field_no = max(keys %$existing_order) || 0; + if ( $last_field_no != scalar keys %$existing_order ) { + croak sprintf + "Table '%s' field order incomplete - unable to auto-determine order for newly added field", + $self->name, + ; + } + + $field->order( $last_field_no + 1 ); + } + # We know we have a name as the Field->new above errors if none given. my $field_name = $field->name; - if ( exists $self->{'fields'}{ $field_name } ) { + if ( $self->get_field($field_name) ) { return $self->error(qq[Can't create field: "$field_name" exists]); } else { @@ -267,14 +334,65 @@ existing field, you will get an error and the field will not be created. 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 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 { =pod =head2 comments -Get or set the comments on a table. May be called several times to +Get or set the comments on a table. May be called several times to set and it will accumulate the comments. Called in an array context, returns each comment individually; called in a scalar context, returns all the comments joined on newlines. @@ -294,17 +412,16 @@ all the comments joined on newlines. } if ( @{ $self->{'comments'} || [] } ) { - return wantarray + return wantarray ? @{ $self->{'comments'} } : join( "\n", @{ $self->{'comments'} } ) ; - } + } else { return wantarray ? () : undef; } } -# ---------------------------------------------------------------------- sub get_constraints { =pod @@ -320,7 +437,7 @@ Returns all the constraint objects as an array or array reference. my $self = shift; if ( ref $self->{'constraints'} ) { - return wantarray + return wantarray ? @{ $self->{'constraints'} } : $self->{'constraints'}; } else { @@ -329,7 +446,6 @@ Returns all the constraint objects as an array or array reference. } } -# ---------------------------------------------------------------------- sub get_indices { =pod @@ -345,8 +461,8 @@ Returns all the index objects as an array or array reference. my $self = shift; if ( ref $self->{'indices'} ) { - return wantarray - ? @{ $self->{'indices'} } + return wantarray + ? @{ $self->{'indices'} } : $self->{'indices'}; } else { @@ -355,7 +471,6 @@ Returns all the index objects as an array or array reference. } } -# ---------------------------------------------------------------------- sub get_field { =pod @@ -370,12 +485,19 @@ Returns a field by the name provided. my $self = shift; my $field_name = shift or return $self->error('No field name'); + my $case_insensitive = shift; + if ( $case_insensitive ) { + $field_name = uc($field_name); + foreach my $field ( keys %{$self->{fields}} ) { + return $self->{fields}{$field} if $field_name eq uc($field); + } + return $self->error(qq[Field "$field_name" does not exist]); + } return $self->error( qq[Field "$field_name" does not exist] ) unless exists $self->{'fields'}{ $field_name }; return $self->{'fields'}{ $field_name }; } -# ---------------------------------------------------------------------- sub get_fields { =pod @@ -389,7 +511,7 @@ Returns all the field objects as an array or array reference. =cut my $self = shift; - my @fields = + my @fields = map { $_->[1] } sort { $a->[0] <=> $b->[0] } map { [ $_->order, $_ ] } @@ -404,7 +526,6 @@ Returns all the field objects as an array or array reference. } } -# ---------------------------------------------------------------------- sub is_valid { =pod @@ -421,8 +542,8 @@ Determine whether the view is valid or not. return $self->error('No name') unless $self->name; return $self->error('No fields') unless $self->get_fields; - for my $object ( - $self->get_fields, $self->get_indices, $self->get_constraints + for my $object ( + $self->get_fields, $self->get_indices, $self->get_constraints ) { return $object->error unless $object->is_valid; } @@ -430,7 +551,6 @@ Determine whether the view is valid or not. return 1; } -# ---------------------------------------------------------------------- sub is_trivial_link { =pod @@ -450,15 +570,15 @@ True if table has no data (non-key) fields and only uses single key joins. my %fk = (); foreach my $field ( $self->get_fields ) { - next unless $field->is_foreign_key; - $fk{$field->foreign_key_reference->reference_table}++; - } + next unless $field->is_foreign_key; + $fk{$field->foreign_key_reference->reference_table}++; + } foreach my $referenced (keys %fk){ - if($fk{$referenced} > 1){ - $self->{'is_trivial_link'} = 0; - last; - } + if($fk{$referenced} > 1){ + $self->{'is_trivial_link'} = 0; + last; + } } return $self->{'is_trivial_link'}; @@ -490,7 +610,6 @@ Returns true if the table has some non-key fields. return $self->{'is_data'}; } -# ---------------------------------------------------------------------- sub can_link { =pod @@ -539,7 +658,7 @@ Determine whether the table can link two arg tables via many-to-many. $self->{'can_link'}{ $table1->name }{ $table2->name } = [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ]; - # non-trivial traversal. one way to link table2, + # non-trivial traversal. one way to link table2, # many ways to link table1 } elsif ( scalar( @{ $fk{ $table1->name } } > 1 ) @@ -550,7 +669,7 @@ Determine whether the table can link two arg tables via many-to-many. $self->{'can_link'}{ $table2->name }{ $table1->name } = [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ]; - # non-trivial traversal. one way to link table1, + # non-trivial traversal. one way to link table1, # many ways to link table2 } elsif ( scalar( @{ $fk{ $table1->name } } == 1 ) @@ -571,7 +690,7 @@ Determine whether the table can link two arg tables via many-to-many. $self->{'can_link'}{ $table2->name }{ $table1->name } = [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ]; - # one of the tables didn't export a key + # one of the tables didn't export a key # to this table, no linking possible } else { @@ -582,7 +701,6 @@ Determine whether the table can link two arg tables via many-to-many. return $self->{'can_link'}{ $table1->name }{ $table2->name }; } -# ---------------------------------------------------------------------- sub name { =pod @@ -615,7 +733,6 @@ that name and disallows the change if one exists (setting the error to return $self->{'name'} || ''; } -# ---------------------------------------------------------------------- sub schema { =pod @@ -638,7 +755,6 @@ Get or set the table's schema object. return $self->{'schema'}; } -# ---------------------------------------------------------------------- sub primary_key { =pod @@ -671,7 +787,7 @@ These are eqivalent: my $constraint; if ( @$fields ) { for my $f ( @$fields ) { - return $self->error(qq[Invalid field "$f"]) unless + return $self->error(qq[Invalid field "$f"]) unless $self->get_field($f); } @@ -681,7 +797,7 @@ These are eqivalent: $has_pk = 1; $c->fields( @{ $c->fields }, @$fields ); $constraint = $c; - } + } } unless ( $has_pk ) { @@ -704,7 +820,6 @@ These are eqivalent: return; } -# ---------------------------------------------------------------------- sub options { =pod @@ -724,14 +839,13 @@ an array or array reference. push @{ $self->{'options'} }, @$options; if ( ref $self->{'options'} ) { - return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'}; + return wantarray ? @{ $self->{'options'} || [] } : ($self->{'options'} || ''); } else { return wantarray ? () : []; } } -# ---------------------------------------------------------------------- sub order { =pod @@ -753,13 +867,12 @@ Get or set the table's order. return $self->{'order'} || 0; } -# ---------------------------------------------------------------------- sub field_names { =head2 field_names Read-only method to return a list or array ref of the field names. Returns undef -or an empty list if the table has no fields set. Usefull if you want to +or an empty list if the table has no fields set. Useful if you want to avoid the overload magic of the Field objects returned by the get_fields method. my @names = $constraint->field_names; @@ -767,7 +880,7 @@ avoid the overload magic of the Field objects returned by the get_fields method. =cut my $self = shift; - my @fields = + my @fields = map { $_->name } sort { $a->order <=> $b->order } values %{ $self->{'fields'} || {} }; @@ -781,12 +894,98 @@ avoid the overload magic of the Field objects returned by the get_fields method. } } -# ---------------------------------------------------------------------- +sub equals { + +=pod + +=head2 equals + +Determines if this table is the same as another + + my $isIdentical = $table1->equals( $table2 ); + +=cut + + my $self = shift; + my $other = shift; + my $case_insensitive = shift; + + return 0 unless $self->SUPER::equals($other); + return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name; + return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options); + return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra); + + # Fields + # Go through our fields + my %checkedFields; + foreach my $field ( $self->get_fields ) { + my $otherField = $other->get_field($field->name, $case_insensitive); + return 0 unless $field->equals($otherField, $case_insensitive); + $checkedFields{$field->name} = 1; + } + # Go through the other table's fields + foreach my $otherField ( $other->get_fields ) { + next if $checkedFields{$otherField->name}; + return 0; + } + + # Constraints + # Go through our constraints + my %checkedConstraints; +CONSTRAINT: + foreach my $constraint ( $self->get_constraints ) { + foreach my $otherConstraint ( $other->get_constraints ) { + if ( $constraint->equals($otherConstraint, $case_insensitive) ) { + $checkedConstraints{$otherConstraint} = 1; + next CONSTRAINT; + } + } + return 0; + } + # Go through the other table's constraints +CONSTRAINT2: + foreach my $otherConstraint ( $other->get_constraints ) { + next if $checkedFields{$otherConstraint}; + foreach my $constraint ( $self->get_constraints ) { + if ( $otherConstraint->equals($constraint, $case_insensitive) ) { + next CONSTRAINT2; + } + } + return 0; + } + + # Indices + # Go through our indices + my %checkedIndices; +INDEX: + foreach my $index ( $self->get_indices ) { + foreach my $otherIndex ( $other->get_indices ) { + if ( $index->equals($otherIndex, $case_insensitive) ) { + $checkedIndices{$otherIndex} = 1; + next INDEX; + } + } + return 0; + } + # Go through the other table's indices +INDEX2: + foreach my $otherIndex ( $other->get_indices ) { + next if $checkedIndices{$otherIndex}; + foreach my $index ( $self->get_indices ) { + if ( $otherIndex->equals($index, $case_insensitive) ) { + next INDEX2; + } + } + return 0; + } + + return 1; +} =head1 LOOKUP METHODS -The following are a set of shortcut methods for getting commonly used lists of -fields and constraints. They all return lists or array refs of Field or +The following are a set of shortcut methods for getting commonly used lists of +fields and constraints. They all return lists or array refs of Field or Constraint objects. =over 4 @@ -830,7 +1029,6 @@ sub pkey_fields { return wantarray ? @fields : \@fields; } -# ---------------------------------------------------------------------- sub fkey_fields { my $me = shift; my @fields; @@ -838,14 +1036,12 @@ sub fkey_fields { return wantarray ? @fields : \@fields; } -# ---------------------------------------------------------------------- sub nonpkey_fields { my $me = shift; my @fields = grep { !$_->is_primary_key } $me->get_fields; return wantarray ? @fields : \@fields; } -# ---------------------------------------------------------------------- sub data_fields { my $me = shift; my @fields = @@ -853,7 +1049,6 @@ sub data_fields { return wantarray ? @fields : \@fields; } -# ---------------------------------------------------------------------- sub unique_fields { my $me = shift; my @fields; @@ -861,21 +1056,18 @@ sub unique_fields { return wantarray ? @fields : \@fields; } -# ---------------------------------------------------------------------- sub unique_constraints { my $me = shift; my @cons = grep { $_->type eq UNIQUE } $me->get_constraints; return wantarray ? @cons : \@cons; } -# ---------------------------------------------------------------------- sub fkey_constraints { my $me = shift; my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints; return wantarray ? @cons : \@cons; } -# ---------------------------------------------------------------------- sub DESTROY { my $self = shift; undef $self->{'schema'}; # destroy cyclical reference @@ -886,13 +1078,11 @@ sub DESTROY { 1; -# ---------------------------------------------------------------------- - =pod =head1 AUTHORS -Ken Y. Clark Ekclark@cpan.orgE, +Ken Youens-Clark Ekclark@cpan.orgE, Allen Day Eallenday@ucla.eduE. =cut