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 $FIELD_ORDER );
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(
80 # ----------------------------------------------------------------------
87 Add a constraint to the table. Returns the newly created
88 C<SQL::Translator::Schema::Constraint> object.
90 my $c1 = $table->add_constraint(
93 fields => [ 'foo_id' ],
96 my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
97 $c2 = $table->add_constraint( $constraint );
102 my $constraint_class = 'SQL::Translator::Schema::Constraint';
105 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
107 $constraint->table( $self );
111 $args{'table'} = $self;
112 $constraint = $constraint_class->new( \%args ) or
113 return $self->error( $constraint_class->error );
117 # If we're trying to add a PK when one is already defined,
118 # then just add the fields to the existing definition.
121 my $pk = $self->primary_key;
122 if ( $pk && $constraint->type eq PRIMARY_KEY ) {
123 $self->primary_key( $constraint->fields );
124 $pk->name($constraint->name) if $constraint->name;
125 my %extra = $constraint->extra;
126 $pk->extra(%extra) if keys %extra;
130 elsif ( $constraint->type eq PRIMARY_KEY ) {
131 for my $fname ( $constraint->fields ) {
132 if ( my $f = $self->get_field( $fname ) ) {
133 $f->is_primary_key( 1 );
138 # See if another constraint of the same type
139 # covers the same fields. -- This doesn't work! ky
141 # elsif ( $constraint->type ne CHECK_C ) {
142 # my @field_names = $constraint->fields;
144 # grep { $_->type eq $constraint->type }
145 # $self->get_constraints
147 # my %fields = map { $_, 1 } $c->fields;
148 # for my $field_name ( @field_names ) {
149 # if ( $fields{ $field_name } ) {
160 push @{ $self->{'constraints'} }, $constraint;
166 # ----------------------------------------------------------------------
167 sub drop_constraint {
171 =head2 drop_constraint
173 Remove a constraint from the table. Returns the constraint object if the index
174 was found and removed, an error otherwise. The single parameter can be either
175 an index name or an C<SQL::Translator::Schema::Constraint> object.
177 $table->drop_constraint('myconstraint');
182 my $constraint_class = 'SQL::Translator::Schema::Constraint';
185 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
186 $constraint_name = shift->name;
189 $constraint_name = shift;
192 if ( ! grep { $_->name eq $constraint_name } @ { $self->{'constraints'} } ) {
193 return $self->error(qq[Can't drop constraint: "$constraint_name" doesn't exist]);
196 my @cs = @{ $self->{'constraints'} };
197 my ($constraint_id) = grep { $cs[$_]->name eq $constraint_name } (0..$#cs);
198 my $constraint = splice(@{$self->{'constraints'}}, $constraint_id, 1);
203 # ----------------------------------------------------------------------
210 Add an index to the table. Returns the newly created
211 C<SQL::Translator::Schema::Index> object.
213 my $i1 = $table->add_index(
215 fields => [ 'name' ],
219 my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
220 $i2 = $table->add_index( $index );
225 my $index_class = 'SQL::Translator::Schema::Index';
228 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
230 $index->table( $self );
234 $args{'table'} = $self;
235 $index = $index_class->new( \%args ) or return
236 $self->error( $index_class->error );
238 foreach my $ex_index ($self->get_indices) {
239 return if ($ex_index->equals($index));
241 push @{ $self->{'indices'} }, $index;
245 # ----------------------------------------------------------------------
252 Remove an index from the table. Returns the index object if the index was
253 found and removed, an error otherwise. The single parameter can be either
254 an index name of an C<SQL::Translator::Schema::Index> object.
256 $table->drop_index('myindex');
261 my $index_class = 'SQL::Translator::Schema::Index';
264 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
265 $index_name = shift->name;
271 if ( ! grep { $_->name eq $index_name } @{ $self->{'indices'} }) {
272 return $self->error(qq[Can't drop index: "$index_name" doesn't exist]);
275 my @is = @{ $self->{'indices'} };
276 my ($index_id) = grep { $is[$_]->name eq $index_name } (0..$#is);
277 my $index = splice(@{$self->{'indices'}}, $index_id, 1);
282 # ----------------------------------------------------------------------
289 Add an field to the table. Returns the newly created
290 C<SQL::Translator::Schema::Field> object. The "name" parameter is
291 required. If you try to create a field with the same name as an
292 existing field, you will get an error and the field will not be created.
294 my $f1 = $table->add_field(
296 data_type => 'integer',
300 my $f2 = SQL::Translator::Schema::Field->new(
304 $f2 = $table->add_field( $field2 ) or die $table->error;
309 my $field_class = 'SQL::Translator::Schema::Field';
312 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
314 $field->table( $self );
318 $args{'table'} = $self;
319 $field = $field_class->new( \%args ) or return
320 $self->error( $field_class->error );
323 $field->order( ++$FIELD_ORDER );
324 # We know we have a name as the Field->new above errors if none given.
325 my $field_name = $field->name;
327 if ( exists $self->{'fields'}{ $field_name } ) {
328 return $self->error(qq[Can't create field: "$field_name" exists]);
331 $self->{'fields'}{ $field_name } = $field;
336 # ----------------------------------------------------------------------
343 Remove a field from the table. Returns the field object if the field was
344 found and removed, an error otherwise. The single parameter can be either
345 a field name or an C<SQL::Translator::Schema::Field> object.
347 $table->drop_field('myfield');
352 my $field_class = 'SQL::Translator::Schema::Field';
355 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
356 $field_name = shift->name;
362 my $cascade = $args{'cascade'};
364 if ( ! exists $self->{'fields'}{ $field_name } ) {
365 return $self->error(qq[Can't drop field: "$field_name" doesn't exists]);
368 my $field = delete $self->{'fields'}{ $field_name };
371 # Remove this field from all indices using it
372 foreach my $i ($self->get_indices()) {
373 my @fs = $i->fields();
374 @fs = grep { $_ ne $field->name } @fs;
378 # Remove this field from all constraints using it
379 foreach my $c ($self->get_constraints()) {
380 my @cs = $c->fields();
381 @cs = grep { $_ ne $field->name } @cs;
389 # ----------------------------------------------------------------------
396 Get or set the comments on a table. May be called several times to
397 set and it will accumulate the comments. Called in an array context,
398 returns each comment individually; called in a scalar context, returns
399 all the comments joined on newlines.
401 $table->comments('foo');
402 $table->comments('bar');
403 print join( ', ', $table->comments ); # prints "foo, bar"
408 my @comments = ref $_[0] ? @{ $_[0] } : @_;
410 for my $arg ( @comments ) {
411 $arg = $arg->[0] if ref $arg;
412 push @{ $self->{'comments'} }, $arg if defined $arg && $arg;
415 if ( @{ $self->{'comments'} || [] } ) {
417 ? @{ $self->{'comments'} }
418 : join( "\n", @{ $self->{'comments'} } )
422 return wantarray ? () : undef;
426 # ----------------------------------------------------------------------
427 sub get_constraints {
431 =head2 get_constraints
433 Returns all the constraint objects as an array or array reference.
435 my @constraints = $table->get_constraints;
441 if ( ref $self->{'constraints'} ) {
443 ? @{ $self->{'constraints'} } : $self->{'constraints'};
446 $self->error('No constraints');
447 return wantarray ? () : undef;
451 # ----------------------------------------------------------------------
458 Returns all the index objects as an array or array reference.
460 my @indices = $table->get_indices;
466 if ( ref $self->{'indices'} ) {
468 ? @{ $self->{'indices'} }
469 : $self->{'indices'};
472 $self->error('No indices');
473 return wantarray ? () : undef;
477 # ----------------------------------------------------------------------
484 Returns a field by the name provided.
486 my $field = $table->get_field('foo');
491 my $field_name = shift or return $self->error('No field name');
492 my $case_insensitive = shift;
493 if ( $case_insensitive ) {
494 $field_name = uc($field_name);
495 foreach my $field ( keys %{$self->{fields}} ) {
496 return $self->{fields}{$field} if $field_name eq uc($field);
498 return $self->error(qq[Field "$field_name" does not exist]);
500 return $self->error( qq[Field "$field_name" does not exist] ) unless
501 exists $self->{'fields'}{ $field_name };
502 return $self->{'fields'}{ $field_name };
505 # ----------------------------------------------------------------------
512 Returns all the field objects as an array or array reference.
514 my @fields = $table->get_fields;
521 sort { $a->[0] <=> $b->[0] }
522 map { [ $_->order, $_ ] }
523 values %{ $self->{'fields'} || {} };
526 return wantarray ? @fields : \@fields;
529 $self->error('No fields');
530 return wantarray ? () : undef;
534 # ----------------------------------------------------------------------
541 Determine whether the view is valid or not.
543 my $ok = $view->is_valid;
548 return $self->error('No name') unless $self->name;
549 return $self->error('No fields') unless $self->get_fields;
552 $self->get_fields, $self->get_indices, $self->get_constraints
554 return $object->error unless $object->is_valid;
560 # ----------------------------------------------------------------------
561 sub is_trivial_link {
565 =head2 is_trivial_link
567 True if table has no data (non-key) fields and only uses single key joins.
572 return 0 if $self->is_data;
573 return $self->{'is_trivial_link'} if defined $self->{'is_trivial_link'};
575 $self->{'is_trivial_link'} = 1;
579 foreach my $field ( $self->get_fields ) {
580 next unless $field->is_foreign_key;
581 $fk{$field->foreign_key_reference->reference_table}++;
584 foreach my $referenced (keys %fk){
585 if($fk{$referenced} > 1){
586 $self->{'is_trivial_link'} = 0;
591 return $self->{'is_trivial_link'};
601 Returns true if the table has some non-key fields.
606 return $self->{'is_data'} if defined $self->{'is_data'};
608 $self->{'is_data'} = 0;
610 foreach my $field ( $self->get_fields ) {
611 if ( !$field->is_primary_key and !$field->is_foreign_key ) {
612 $self->{'is_data'} = 1;
613 return $self->{'is_data'};
617 return $self->{'is_data'};
620 # ----------------------------------------------------------------------
627 Determine whether the table can link two arg tables via many-to-many.
629 my $ok = $table->can_link($table1,$table2);
633 my ( $self, $table1, $table2 ) = @_;
635 return $self->{'can_link'}{ $table1->name }{ $table2->name }
636 if defined $self->{'can_link'}{ $table1->name }{ $table2->name };
638 if ( $self->is_data == 1 ) {
639 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
640 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
641 return $self->{'can_link'}{ $table1->name }{ $table2->name };
646 foreach my $field ( $self->get_fields ) {
647 if ( $field->is_foreign_key ) {
648 push @{ $fk{ $field->foreign_key_reference->reference_table } },
649 $field->foreign_key_reference;
653 if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
655 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
656 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
657 return $self->{'can_link'}{ $table1->name }{ $table2->name };
660 # trivial traversal, only one way to link the two tables
661 if ( scalar( @{ $fk{ $table1->name } } == 1 )
662 and scalar( @{ $fk{ $table2->name } } == 1 ) )
664 $self->{'can_link'}{ $table1->name }{ $table2->name } =
665 [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
666 $self->{'can_link'}{ $table1->name }{ $table2->name } =
667 [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
669 # non-trivial traversal. one way to link table2,
670 # many ways to link table1
672 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
673 and scalar( @{ $fk{ $table2->name } } == 1 ) )
675 $self->{'can_link'}{ $table1->name }{ $table2->name } =
676 [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
677 $self->{'can_link'}{ $table2->name }{ $table1->name } =
678 [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
680 # non-trivial traversal. one way to link table1,
681 # many ways to link table2
683 elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
684 and scalar( @{ $fk{ $table2->name } } > 1 ) )
686 $self->{'can_link'}{ $table1->name }{ $table2->name } =
687 [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
688 $self->{'can_link'}{ $table2->name }{ $table1->name } =
689 [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
691 # non-trivial traversal. many ways to link table1 and table2
693 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
694 and scalar( @{ $fk{ $table2->name } } > 1 ) )
696 $self->{'can_link'}{ $table1->name }{ $table2->name } =
697 [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
698 $self->{'can_link'}{ $table2->name }{ $table1->name } =
699 [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
701 # one of the tables didn't export a key
702 # to this table, no linking possible
705 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
706 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
709 return $self->{'can_link'}{ $table1->name }{ $table2->name };
712 # ----------------------------------------------------------------------
719 Get or set the table's name.
721 Errors ("No table name") if you try to set a blank name.
723 If provided an argument, checks the schema object for a table of
724 that name and disallows the change if one exists (setting the error to
725 "Can't use table name "%s": table exists").
727 my $table_name = $table->name('foo');
734 my $arg = shift || return $self->error( "No table name" );
735 if ( my $schema = $self->schema ) {
736 return $self->error( qq[Can't use table name "$arg": table exists] )
737 if $schema->get_table( $arg );
739 $self->{'name'} = $arg;
742 return $self->{'name'} || '';
745 # ----------------------------------------------------------------------
752 Get or set the table's schema object.
754 my $schema = $table->schema;
759 if ( my $arg = shift ) {
760 return $self->error('Not a schema object') unless
761 UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
762 $self->{'schema'} = $arg;
765 return $self->{'schema'};
768 # ----------------------------------------------------------------------
775 Gets or sets the table's primary key(s). Takes one or more field
776 names (as a string, list or array[ref]) as an argument. If the field
777 names are present, it will create a new PK if none exists, or it will
778 add to the fields of an existing PK (and will unique the field names).
779 Returns the C<SQL::Translator::Schema::Constraint> object representing
784 $table->primary_key('id');
785 $table->primary_key(['name']);
786 $table->primary_key('id','name']);
787 $table->primary_key(['id','name']);
788 $table->primary_key('id,name');
789 $table->primary_key(qw[ id name ]);
791 my $pk = $table->primary_key;
796 my $fields = parse_list_arg( @_ );
800 for my $f ( @$fields ) {
801 return $self->error(qq[Invalid field "$f"]) unless
802 $self->get_field($f);
806 for my $c ( $self->get_constraints ) {
807 if ( $c->type eq PRIMARY_KEY ) {
809 $c->fields( @{ $c->fields }, @$fields );
815 $constraint = $self->add_constraint(
826 for my $c ( $self->get_constraints ) {
827 return $c if $c->type eq PRIMARY_KEY;
834 # ----------------------------------------------------------------------
841 Get or set the table's options (e.g., table types for MySQL). Returns
842 an array or array reference.
844 my @options = $table->options;
849 my $options = parse_list_arg( @_ );
851 push @{ $self->{'options'} }, @$options;
853 if ( ref $self->{'options'} ) {
854 return wantarray ? @{ $self->{'options'} || [] } : ($self->{'options'} || '');
857 return wantarray ? () : [];
861 # ----------------------------------------------------------------------
868 Get or set the table's order.
870 my $order = $table->order(3);
874 my ( $self, $arg ) = @_;
876 if ( defined $arg && $arg =~ /^\d+$/ ) {
877 $self->{'order'} = $arg;
880 return $self->{'order'} || 0;
883 # ----------------------------------------------------------------------
888 Read-only method to return a list or array ref of the field names. Returns undef
889 or an empty list if the table has no fields set. Usefull if you want to
890 avoid the overload magic of the Field objects returned by the get_fields method.
892 my @names = $constraint->field_names;
899 sort { $a->order <=> $b->order }
900 values %{ $self->{'fields'} || {} };
903 return wantarray ? @fields : \@fields;
906 $self->error('No fields');
907 return wantarray ? () : undef;
911 # ----------------------------------------------------------------------
918 Determines if this table is the same as another
920 my $isIdentical = $table1->equals( $table2 );
926 my $case_insensitive = shift;
928 return 0 unless $self->SUPER::equals($other);
929 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
930 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
931 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
934 # Go through our fields
936 foreach my $field ( $self->get_fields ) {
937 my $otherField = $other->get_field($field->name, $case_insensitive);
938 return 0 unless $field->equals($otherField, $case_insensitive);
939 $checkedFields{$field->name} = 1;
941 # Go through the other table's fields
942 foreach my $otherField ( $other->get_fields ) {
943 next if $checkedFields{$otherField->name};
948 # Go through our constraints
949 my %checkedConstraints;
951 foreach my $constraint ( $self->get_constraints ) {
952 foreach my $otherConstraint ( $other->get_constraints ) {
953 if ( $constraint->equals($otherConstraint, $case_insensitive) ) {
954 $checkedConstraints{$otherConstraint} = 1;
960 # Go through the other table's constraints
962 foreach my $otherConstraint ( $other->get_constraints ) {
963 next if $checkedFields{$otherConstraint};
964 foreach my $constraint ( $self->get_constraints ) {
965 if ( $otherConstraint->equals($constraint, $case_insensitive) ) {
973 # Go through our indices
976 foreach my $index ( $self->get_indices ) {
977 foreach my $otherIndex ( $other->get_indices ) {
978 if ( $index->equals($otherIndex, $case_insensitive) ) {
979 $checkedIndices{$otherIndex} = 1;
985 # Go through the other table's indices
987 foreach my $otherIndex ( $other->get_indices ) {
988 next if $checkedIndices{$otherIndex};
989 foreach my $index ( $self->get_indices ) {
990 if ( $otherIndex->equals($index, $case_insensitive) ) {
1000 # ----------------------------------------------------------------------
1002 =head1 LOOKUP METHODS
1004 The following are a set of shortcut methods for getting commonly used lists of
1005 fields and constraints. They all return lists or array refs of Field or
1012 The primary key fields.
1016 All foreign key fields.
1018 =item nonpkey_fields
1020 All the fields except the primary key.
1028 All fields with unique constraints.
1030 =item unique_constraints
1032 All this tables unique constraints.
1034 =item fkey_constraints
1036 All this tables foreign key constraints. (See primary_key method to get the
1037 primary key constraint)
1045 my @fields = grep { $_->is_primary_key } $me->get_fields;
1046 return wantarray ? @fields : \@fields;
1049 # ----------------------------------------------------------------------
1053 push @fields, $_->fields foreach $me->fkey_constraints;
1054 return wantarray ? @fields : \@fields;
1057 # ----------------------------------------------------------------------
1058 sub nonpkey_fields {
1060 my @fields = grep { !$_->is_primary_key } $me->get_fields;
1061 return wantarray ? @fields : \@fields;
1064 # ----------------------------------------------------------------------
1068 grep { !$_->is_foreign_key and !$_->is_primary_key } $me->get_fields;
1069 return wantarray ? @fields : \@fields;
1072 # ----------------------------------------------------------------------
1076 push @fields, $_->fields foreach $me->unique_constraints;
1077 return wantarray ? @fields : \@fields;
1080 # ----------------------------------------------------------------------
1081 sub unique_constraints {
1083 my @cons = grep { $_->type eq UNIQUE } $me->get_constraints;
1084 return wantarray ? @cons : \@cons;
1087 # ----------------------------------------------------------------------
1088 sub fkey_constraints {
1090 my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints;
1091 return wantarray ? @cons : \@cons;
1094 # ----------------------------------------------------------------------
1097 undef $self->{'schema'}; # destroy cyclical reference
1098 undef $_ for @{ $self->{'constraints'} };
1099 undef $_ for @{ $self->{'indices'} };
1100 undef $_ for values %{ $self->{'fields'} };
1105 # ----------------------------------------------------------------------
1111 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
1112 Allen Day E<lt>allenday@ucla.eduE<gt>.