1 package SQL::Translator::Schema::Table;
3 # ----------------------------------------------------------------------
4 # Copyright (C) 2002-2009 SQLFairy Authors
6 # This program is free software; you can redistribute it and/or
7 # modify it under the terms of the GNU General Public License as
8 # published by the Free Software Foundation; version 2.
10 # This program is distributed in the hope that it will be useful, but
11 # WITHOUT ANY WARRANTY; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 # General Public License for more details.
15 # You should have received a copy of the GNU General Public License
16 # along with this program; if not, write to the Free Software
17 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
19 # -------------------------------------------------------------------
25 SQL::Translator::Schema::Table - SQL::Translator table object
29 use SQL::Translator::Schema::Table;
30 my $table = SQL::Translator::Schema::Table->new( name => 'foo' );
34 C<SQL::Translator::Schema::Table> is the table object.
41 use SQL::Translator::Utils 'parse_list_arg';
42 use SQL::Translator::Schema::Constants;
43 use SQL::Translator::Schema::Constraint;
44 use SQL::Translator::Schema::Field;
45 use SQL::Translator::Schema::Index;
48 use base 'SQL::Translator::Schema::Object';
50 use vars qw( $VERSION );
54 # Stringify to our name, being careful not to pass any args through so we don't
55 # accidentally set it to undef. We also have to tweak bool so the object is
56 # still true when it doesn't have a name (which shouldn't happen!).
58 '""' => sub { shift->name },
59 'bool' => sub { $_[0]->name || $_[0] },
63 # ----------------------------------------------------------------------
65 __PACKAGE__->_attributes( qw/schema name comments options order/ );
73 my $table = SQL::Translator::Schema::Table->new(
82 my $self = $class->SUPER::new (@_)
85 $self->{_order} = { map { $_ => 0 } qw/
94 # ----------------------------------------------------------------------
101 Add a constraint to the table. Returns the newly created
102 C<SQL::Translator::Schema::Constraint> object.
104 my $c1 = $table->add_constraint(
107 fields => [ 'foo_id' ],
110 my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
111 $c2 = $table->add_constraint( $constraint );
116 my $constraint_class = 'SQL::Translator::Schema::Constraint';
119 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
121 $constraint->table( $self );
125 $args{'table'} = $self;
126 $constraint = $constraint_class->new( \%args ) or
127 return $self->error( $constraint_class->error );
131 # If we're trying to add a PK when one is already defined,
132 # then just add the fields to the existing definition.
135 my $pk = $self->primary_key;
136 if ( $pk && $constraint->type eq PRIMARY_KEY ) {
137 $self->primary_key( $constraint->fields );
138 $pk->name($constraint->name) if $constraint->name;
139 my %extra = $constraint->extra;
140 $pk->extra(%extra) if keys %extra;
144 elsif ( $constraint->type eq PRIMARY_KEY ) {
145 for my $fname ( $constraint->fields ) {
146 if ( my $f = $self->get_field( $fname ) ) {
147 $f->is_primary_key( 1 );
152 # See if another constraint of the same type
153 # covers the same fields. -- This doesn't work! ky
155 # elsif ( $constraint->type ne CHECK_C ) {
156 # my @field_names = $constraint->fields;
158 # grep { $_->type eq $constraint->type }
159 # $self->get_constraints
161 # my %fields = map { $_, 1 } $c->fields;
162 # for my $field_name ( @field_names ) {
163 # if ( $fields{ $field_name } ) {
174 push @{ $self->{'constraints'} }, $constraint;
180 # ----------------------------------------------------------------------
181 sub drop_constraint {
185 =head2 drop_constraint
187 Remove a constraint from the table. Returns the constraint object if the index
188 was found and removed, an error otherwise. The single parameter can be either
189 an index name or an C<SQL::Translator::Schema::Constraint> object.
191 $table->drop_constraint('myconstraint');
196 my $constraint_class = 'SQL::Translator::Schema::Constraint';
199 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
200 $constraint_name = shift->name;
203 $constraint_name = shift;
206 if ( ! grep { $_->name eq $constraint_name } @ { $self->{'constraints'} } ) {
207 return $self->error(qq[Can't drop constraint: "$constraint_name" doesn't exist]);
210 my @cs = @{ $self->{'constraints'} };
211 my ($constraint_id) = grep { $cs[$_]->name eq $constraint_name } (0..$#cs);
212 my $constraint = splice(@{$self->{'constraints'}}, $constraint_id, 1);
217 # ----------------------------------------------------------------------
224 Add an index to the table. Returns the newly created
225 C<SQL::Translator::Schema::Index> object.
227 my $i1 = $table->add_index(
229 fields => [ 'name' ],
233 my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
234 $i2 = $table->add_index( $index );
239 my $index_class = 'SQL::Translator::Schema::Index';
242 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
244 $index->table( $self );
248 $args{'table'} = $self;
249 $index = $index_class->new( \%args ) or return
250 $self->error( $index_class->error );
252 foreach my $ex_index ($self->get_indices) {
253 return if ($ex_index->equals($index));
255 push @{ $self->{'indices'} }, $index;
259 # ----------------------------------------------------------------------
266 Remove an index from the table. Returns the index object if the index was
267 found and removed, an error otherwise. The single parameter can be either
268 an index name of an C<SQL::Translator::Schema::Index> object.
270 $table->drop_index('myindex');
275 my $index_class = 'SQL::Translator::Schema::Index';
278 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
279 $index_name = shift->name;
285 if ( ! grep { $_->name eq $index_name } @{ $self->{'indices'} }) {
286 return $self->error(qq[Can't drop index: "$index_name" doesn't exist]);
289 my @is = @{ $self->{'indices'} };
290 my ($index_id) = grep { $is[$_]->name eq $index_name } (0..$#is);
291 my $index = splice(@{$self->{'indices'}}, $index_id, 1);
296 # ----------------------------------------------------------------------
303 Add an field to the table. Returns the newly created
304 C<SQL::Translator::Schema::Field> object. The "name" parameter is
305 required. If you try to create a field with the same name as an
306 existing field, you will get an error and the field will not be created.
308 my $f1 = $table->add_field(
310 data_type => 'integer',
314 my $f2 = SQL::Translator::Schema::Field->new(
318 $f2 = $table->add_field( $field2 ) or die $table->error;
323 my $field_class = 'SQL::Translator::Schema::Field';
326 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
328 $field->table( $self );
332 $args{'table'} = $self;
333 $field = $field_class->new( \%args ) or return
334 $self->error( $field_class->error );
337 $field->order( ++$self->{_order}{field} );
338 # We know we have a name as the Field->new above errors if none given.
339 my $field_name = $field->name;
341 if ( exists $self->{'fields'}{ $field_name } ) {
342 return $self->error(qq[Can't create field: "$field_name" exists]);
345 $self->{'fields'}{ $field_name } = $field;
350 # ----------------------------------------------------------------------
357 Remove a field from the table. Returns the field object if the field was
358 found and removed, an error otherwise. The single parameter can be either
359 a field name or an C<SQL::Translator::Schema::Field> object.
361 $table->drop_field('myfield');
366 my $field_class = 'SQL::Translator::Schema::Field';
369 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
370 $field_name = shift->name;
376 my $cascade = $args{'cascade'};
378 if ( ! exists $self->{'fields'}{ $field_name } ) {
379 return $self->error(qq[Can't drop field: "$field_name" doesn't exists]);
382 my $field = delete $self->{'fields'}{ $field_name };
385 # Remove this field from all indices using it
386 foreach my $i ($self->get_indices()) {
387 my @fs = $i->fields();
388 @fs = grep { $_ ne $field->name } @fs;
392 # Remove this field from all constraints using it
393 foreach my $c ($self->get_constraints()) {
394 my @cs = $c->fields();
395 @cs = grep { $_ ne $field->name } @cs;
403 # ----------------------------------------------------------------------
410 Get or set the comments on a table. May be called several times to
411 set and it will accumulate the comments. Called in an array context,
412 returns each comment individually; called in a scalar context, returns
413 all the comments joined on newlines.
415 $table->comments('foo');
416 $table->comments('bar');
417 print join( ', ', $table->comments ); # prints "foo, bar"
422 my @comments = ref $_[0] ? @{ $_[0] } : @_;
424 for my $arg ( @comments ) {
425 $arg = $arg->[0] if ref $arg;
426 push @{ $self->{'comments'} }, $arg if defined $arg && $arg;
429 if ( @{ $self->{'comments'} || [] } ) {
431 ? @{ $self->{'comments'} }
432 : join( "\n", @{ $self->{'comments'} } )
436 return wantarray ? () : undef;
440 # ----------------------------------------------------------------------
441 sub get_constraints {
445 =head2 get_constraints
447 Returns all the constraint objects as an array or array reference.
449 my @constraints = $table->get_constraints;
455 if ( ref $self->{'constraints'} ) {
457 ? @{ $self->{'constraints'} } : $self->{'constraints'};
460 $self->error('No constraints');
461 return wantarray ? () : undef;
465 # ----------------------------------------------------------------------
472 Returns all the index objects as an array or array reference.
474 my @indices = $table->get_indices;
480 if ( ref $self->{'indices'} ) {
482 ? @{ $self->{'indices'} }
483 : $self->{'indices'};
486 $self->error('No indices');
487 return wantarray ? () : undef;
491 # ----------------------------------------------------------------------
498 Returns a field by the name provided.
500 my $field = $table->get_field('foo');
505 my $field_name = shift or return $self->error('No field name');
506 my $case_insensitive = shift;
507 if ( $case_insensitive ) {
508 $field_name = uc($field_name);
509 foreach my $field ( keys %{$self->{fields}} ) {
510 return $self->{fields}{$field} if $field_name eq uc($field);
512 return $self->error(qq[Field "$field_name" does not exist]);
514 return $self->error( qq[Field "$field_name" does not exist] ) unless
515 exists $self->{'fields'}{ $field_name };
516 return $self->{'fields'}{ $field_name };
519 # ----------------------------------------------------------------------
526 Returns all the field objects as an array or array reference.
528 my @fields = $table->get_fields;
535 sort { $a->[0] <=> $b->[0] }
536 map { [ $_->order, $_ ] }
537 values %{ $self->{'fields'} || {} };
540 return wantarray ? @fields : \@fields;
543 $self->error('No fields');
544 return wantarray ? () : undef;
548 # ----------------------------------------------------------------------
555 Determine whether the view is valid or not.
557 my $ok = $view->is_valid;
562 return $self->error('No name') unless $self->name;
563 return $self->error('No fields') unless $self->get_fields;
566 $self->get_fields, $self->get_indices, $self->get_constraints
568 return $object->error unless $object->is_valid;
574 # ----------------------------------------------------------------------
575 sub is_trivial_link {
579 =head2 is_trivial_link
581 True if table has no data (non-key) fields and only uses single key joins.
586 return 0 if $self->is_data;
587 return $self->{'is_trivial_link'} if defined $self->{'is_trivial_link'};
589 $self->{'is_trivial_link'} = 1;
593 foreach my $field ( $self->get_fields ) {
594 next unless $field->is_foreign_key;
595 $fk{$field->foreign_key_reference->reference_table}++;
598 foreach my $referenced (keys %fk){
599 if($fk{$referenced} > 1){
600 $self->{'is_trivial_link'} = 0;
605 return $self->{'is_trivial_link'};
615 Returns true if the table has some non-key fields.
620 return $self->{'is_data'} if defined $self->{'is_data'};
622 $self->{'is_data'} = 0;
624 foreach my $field ( $self->get_fields ) {
625 if ( !$field->is_primary_key and !$field->is_foreign_key ) {
626 $self->{'is_data'} = 1;
627 return $self->{'is_data'};
631 return $self->{'is_data'};
634 # ----------------------------------------------------------------------
641 Determine whether the table can link two arg tables via many-to-many.
643 my $ok = $table->can_link($table1,$table2);
647 my ( $self, $table1, $table2 ) = @_;
649 return $self->{'can_link'}{ $table1->name }{ $table2->name }
650 if defined $self->{'can_link'}{ $table1->name }{ $table2->name };
652 if ( $self->is_data == 1 ) {
653 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
654 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
655 return $self->{'can_link'}{ $table1->name }{ $table2->name };
660 foreach my $field ( $self->get_fields ) {
661 if ( $field->is_foreign_key ) {
662 push @{ $fk{ $field->foreign_key_reference->reference_table } },
663 $field->foreign_key_reference;
667 if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
669 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
670 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
671 return $self->{'can_link'}{ $table1->name }{ $table2->name };
674 # trivial traversal, only one way to link the two tables
675 if ( scalar( @{ $fk{ $table1->name } } == 1 )
676 and scalar( @{ $fk{ $table2->name } } == 1 ) )
678 $self->{'can_link'}{ $table1->name }{ $table2->name } =
679 [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
680 $self->{'can_link'}{ $table1->name }{ $table2->name } =
681 [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
683 # non-trivial traversal. one way to link table2,
684 # many ways to link table1
686 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
687 and scalar( @{ $fk{ $table2->name } } == 1 ) )
689 $self->{'can_link'}{ $table1->name }{ $table2->name } =
690 [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
691 $self->{'can_link'}{ $table2->name }{ $table1->name } =
692 [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
694 # non-trivial traversal. one way to link table1,
695 # many ways to link table2
697 elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
698 and scalar( @{ $fk{ $table2->name } } > 1 ) )
700 $self->{'can_link'}{ $table1->name }{ $table2->name } =
701 [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
702 $self->{'can_link'}{ $table2->name }{ $table1->name } =
703 [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
705 # non-trivial traversal. many ways to link table1 and table2
707 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
708 and scalar( @{ $fk{ $table2->name } } > 1 ) )
710 $self->{'can_link'}{ $table1->name }{ $table2->name } =
711 [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
712 $self->{'can_link'}{ $table2->name }{ $table1->name } =
713 [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
715 # one of the tables didn't export a key
716 # to this table, no linking possible
719 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
720 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
723 return $self->{'can_link'}{ $table1->name }{ $table2->name };
726 # ----------------------------------------------------------------------
733 Get or set the table's name.
735 Errors ("No table name") if you try to set a blank name.
737 If provided an argument, checks the schema object for a table of
738 that name and disallows the change if one exists (setting the error to
739 "Can't use table name "%s": table exists").
741 my $table_name = $table->name('foo');
748 my $arg = shift || return $self->error( "No table name" );
749 if ( my $schema = $self->schema ) {
750 return $self->error( qq[Can't use table name "$arg": table exists] )
751 if $schema->get_table( $arg );
753 $self->{'name'} = $arg;
756 return $self->{'name'} || '';
759 # ----------------------------------------------------------------------
766 Get or set the table's schema object.
768 my $schema = $table->schema;
773 if ( my $arg = shift ) {
774 return $self->error('Not a schema object') unless
775 UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
776 $self->{'schema'} = $arg;
779 return $self->{'schema'};
782 # ----------------------------------------------------------------------
789 Gets or sets the table's primary key(s). Takes one or more field
790 names (as a string, list or array[ref]) as an argument. If the field
791 names are present, it will create a new PK if none exists, or it will
792 add to the fields of an existing PK (and will unique the field names).
793 Returns the C<SQL::Translator::Schema::Constraint> object representing
798 $table->primary_key('id');
799 $table->primary_key(['name']);
800 $table->primary_key('id','name']);
801 $table->primary_key(['id','name']);
802 $table->primary_key('id,name');
803 $table->primary_key(qw[ id name ]);
805 my $pk = $table->primary_key;
810 my $fields = parse_list_arg( @_ );
814 for my $f ( @$fields ) {
815 return $self->error(qq[Invalid field "$f"]) unless
816 $self->get_field($f);
820 for my $c ( $self->get_constraints ) {
821 if ( $c->type eq PRIMARY_KEY ) {
823 $c->fields( @{ $c->fields }, @$fields );
829 $constraint = $self->add_constraint(
840 for my $c ( $self->get_constraints ) {
841 return $c if $c->type eq PRIMARY_KEY;
848 # ----------------------------------------------------------------------
855 Get or set the table's options (e.g., table types for MySQL). Returns
856 an array or array reference.
858 my @options = $table->options;
863 my $options = parse_list_arg( @_ );
865 push @{ $self->{'options'} }, @$options;
867 if ( ref $self->{'options'} ) {
868 return wantarray ? @{ $self->{'options'} || [] } : ($self->{'options'} || '');
871 return wantarray ? () : [];
875 # ----------------------------------------------------------------------
882 Get or set the table's order.
884 my $order = $table->order(3);
888 my ( $self, $arg ) = @_;
890 if ( defined $arg && $arg =~ /^\d+$/ ) {
891 $self->{'order'} = $arg;
894 return $self->{'order'} || 0;
897 # ----------------------------------------------------------------------
902 Read-only method to return a list or array ref of the field names. Returns undef
903 or an empty list if the table has no fields set. Usefull if you want to
904 avoid the overload magic of the Field objects returned by the get_fields method.
906 my @names = $constraint->field_names;
913 sort { $a->order <=> $b->order }
914 values %{ $self->{'fields'} || {} };
917 return wantarray ? @fields : \@fields;
920 $self->error('No fields');
921 return wantarray ? () : undef;
925 # ----------------------------------------------------------------------
932 Determines if this table is the same as another
934 my $isIdentical = $table1->equals( $table2 );
940 my $case_insensitive = shift;
942 return 0 unless $self->SUPER::equals($other);
943 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
944 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
945 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
948 # Go through our fields
950 foreach my $field ( $self->get_fields ) {
951 my $otherField = $other->get_field($field->name, $case_insensitive);
952 return 0 unless $field->equals($otherField, $case_insensitive);
953 $checkedFields{$field->name} = 1;
955 # Go through the other table's fields
956 foreach my $otherField ( $other->get_fields ) {
957 next if $checkedFields{$otherField->name};
962 # Go through our constraints
963 my %checkedConstraints;
965 foreach my $constraint ( $self->get_constraints ) {
966 foreach my $otherConstraint ( $other->get_constraints ) {
967 if ( $constraint->equals($otherConstraint, $case_insensitive) ) {
968 $checkedConstraints{$otherConstraint} = 1;
974 # Go through the other table's constraints
976 foreach my $otherConstraint ( $other->get_constraints ) {
977 next if $checkedFields{$otherConstraint};
978 foreach my $constraint ( $self->get_constraints ) {
979 if ( $otherConstraint->equals($constraint, $case_insensitive) ) {
987 # Go through our indices
990 foreach my $index ( $self->get_indices ) {
991 foreach my $otherIndex ( $other->get_indices ) {
992 if ( $index->equals($otherIndex, $case_insensitive) ) {
993 $checkedIndices{$otherIndex} = 1;
999 # Go through the other table's indices
1001 foreach my $otherIndex ( $other->get_indices ) {
1002 next if $checkedIndices{$otherIndex};
1003 foreach my $index ( $self->get_indices ) {
1004 if ( $otherIndex->equals($index, $case_insensitive) ) {
1014 # ----------------------------------------------------------------------
1016 =head1 LOOKUP METHODS
1018 The following are a set of shortcut methods for getting commonly used lists of
1019 fields and constraints. They all return lists or array refs of Field or
1026 The primary key fields.
1030 All foreign key fields.
1032 =item nonpkey_fields
1034 All the fields except the primary key.
1042 All fields with unique constraints.
1044 =item unique_constraints
1046 All this tables unique constraints.
1048 =item fkey_constraints
1050 All this tables foreign key constraints. (See primary_key method to get the
1051 primary key constraint)
1059 my @fields = grep { $_->is_primary_key } $me->get_fields;
1060 return wantarray ? @fields : \@fields;
1063 # ----------------------------------------------------------------------
1067 push @fields, $_->fields foreach $me->fkey_constraints;
1068 return wantarray ? @fields : \@fields;
1071 # ----------------------------------------------------------------------
1072 sub nonpkey_fields {
1074 my @fields = grep { !$_->is_primary_key } $me->get_fields;
1075 return wantarray ? @fields : \@fields;
1078 # ----------------------------------------------------------------------
1082 grep { !$_->is_foreign_key and !$_->is_primary_key } $me->get_fields;
1083 return wantarray ? @fields : \@fields;
1086 # ----------------------------------------------------------------------
1090 push @fields, $_->fields foreach $me->unique_constraints;
1091 return wantarray ? @fields : \@fields;
1094 # ----------------------------------------------------------------------
1095 sub unique_constraints {
1097 my @cons = grep { $_->type eq UNIQUE } $me->get_constraints;
1098 return wantarray ? @cons : \@cons;
1101 # ----------------------------------------------------------------------
1102 sub fkey_constraints {
1104 my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints;
1105 return wantarray ? @cons : \@cons;
1108 # ----------------------------------------------------------------------
1111 undef $self->{'schema'}; # destroy cyclical reference
1112 undef $_ for @{ $self->{'constraints'} };
1113 undef $_ for @{ $self->{'indices'} };
1114 undef $_ for values %{ $self->{'fields'} };
1119 # ----------------------------------------------------------------------
1125 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
1126 Allen Day E<lt>allenday@ucla.eduE<gt>.