1 package SQL::Translator::Schema::Table;
3 # ----------------------------------------------------------------------
4 # $Id: Table.pm,v 1.31 2005-06-27 21:59:20 duality72 Exp $
5 # ----------------------------------------------------------------------
6 # Copyright (C) 2002-4 SQLFairy Authors
8 # This program is free software; you can redistribute it and/or
9 # modify it under the terms of the GNU General Public License as
10 # published by the Free Software Foundation; version 2.
12 # This program is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 # General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program; if not, write to the Free Software
19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
21 # -------------------------------------------------------------------
27 SQL::Translator::Schema::Table - SQL::Translator table object
31 use SQL::Translator::Schema::Table;
32 my $table = SQL::Translator::Schema::Table->new( name => 'foo' );
36 C<SQL::Translator::Schema::Table> is the table object.
43 use SQL::Translator::Utils 'parse_list_arg';
44 use SQL::Translator::Schema::Constants;
45 use SQL::Translator::Schema::Constraint;
46 use SQL::Translator::Schema::Field;
47 use SQL::Translator::Schema::Index;
50 use base 'SQL::Translator::Schema::Object';
52 use vars qw( $VERSION $FIELD_ORDER );
54 $VERSION = sprintf "%d.%02d", q$Revision: 1.31 $ =~ /(\d+)\.(\d+)/;
57 # Stringify to our name, being careful not to pass any args through so we don't
58 # accidentally set it to undef. We also have to tweak bool so the object is
59 # still true when it doesn't have a name (which shouldn't happen!).
61 '""' => sub { shift->name },
62 'bool' => sub { $_[0]->name || $_[0] },
66 # ----------------------------------------------------------------------
68 __PACKAGE__->_attributes( qw/schema name comments options order/ );
76 my $table = SQL::Translator::Schema::Table->new(
83 # ----------------------------------------------------------------------
90 Add a constraint to the table. Returns the newly created
91 C<SQL::Translator::Schema::Constraint> object.
93 my $c1 = $table->add_constraint(
96 fields => [ 'foo_id' ],
99 my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
100 $c2 = $table->add_constraint( $constraint );
105 my $constraint_class = 'SQL::Translator::Schema::Constraint';
108 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
110 $constraint->table( $self );
114 $args{'table'} = $self;
115 $constraint = $constraint_class->new( \%args ) or
116 return $self->error( $constraint_class->error );
120 # If we're trying to add a PK when one is already defined,
121 # then just add the fields to the existing definition.
124 my $pk = $self->primary_key;
125 if ( $pk && $constraint->type eq PRIMARY_KEY ) {
126 $self->primary_key( $constraint->fields );
127 $pk->name($constraint->name) if $constraint->name;
128 my %extra = $constraint->extra;
129 $pk->extra(%extra) if keys %extra;
133 elsif ( $constraint->type eq PRIMARY_KEY ) {
134 for my $fname ( $constraint->fields ) {
135 if ( my $f = $self->get_field( $fname ) ) {
136 $f->is_primary_key( 1 );
141 # See if another constraint of the same type
142 # covers the same fields. -- This doesn't work! ky
144 # elsif ( $constraint->type ne CHECK_C ) {
145 # my @field_names = $constraint->fields;
147 # grep { $_->type eq $constraint->type }
148 # $self->get_constraints
150 # my %fields = map { $_, 1 } $c->fields;
151 # for my $field_name ( @field_names ) {
152 # if ( $fields{ $field_name } ) {
163 push @{ $self->{'constraints'} }, $constraint;
169 # ----------------------------------------------------------------------
170 sub drop_constraint {
174 =head2 drop_constraint
176 Remove a constraint from the table. Returns the constraint object if the index
177 was found and removed, an error otherwise. The single parameter can be either
178 an index name or an C<SQL::Translator::Schema::Constraint> object.
180 $table->drop_constraint('myconstraint');
185 my $constraint_class = 'SQL::Translator::Schema::Constraint';
188 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
189 $constraint_name = shift->name;
192 $constraint_name = shift;
195 if ( ! grep { $_->name eq $constraint_name } @ { $self->{'constraints'} } ) {
196 return $self->error(qq[Can't drop constraint: "$constraint_name" doesn't exist]);
199 my @cs = @{ $self->{'constraints'} };
200 my ($constraint_id) = grep { $cs[$_]->name eq $constraint_name } (0..$#cs);
201 my $constraint = splice(@{$self->{'constraints'}}, $constraint_id, 1);
206 # ----------------------------------------------------------------------
213 Add an index to the table. Returns the newly created
214 C<SQL::Translator::Schema::Index> object.
216 my $i1 = $table->add_index(
218 fields => [ 'name' ],
222 my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
223 $i2 = $table->add_index( $index );
228 my $index_class = 'SQL::Translator::Schema::Index';
231 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
233 $index->table( $self );
237 $args{'table'} = $self;
238 $index = $index_class->new( \%args ) or return
239 $self->error( $index_class->error );
242 push @{ $self->{'indices'} }, $index;
246 # ----------------------------------------------------------------------
253 Remove an index from the table. Returns the index object if the index was
254 found and removed, an error otherwise. The single parameter can be either
255 an index name of an C<SQL::Translator::Schema::Index> object.
257 $table->drop_index('myindex');
262 my $index_class = 'SQL::Translator::Schema::Index';
265 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
266 $index_name = shift->name;
272 if ( ! grep { $_->name eq $index_name } @{ $self->{'indices'} }) {
273 return $self->error(qq[Can't drop index: "$index_name" doesn't exist]);
276 my @is = @{ $self->{'indices'} };
277 my ($index_id) = grep { $is[$_]->name eq $index_name } (0..$#is);
278 my $index = splice(@{$self->{'indices'}}, $index_id, 1);
283 # ----------------------------------------------------------------------
290 Add an field to the table. Returns the newly created
291 C<SQL::Translator::Schema::Field> object. The "name" parameter is
292 required. If you try to create a field with the same name as an
293 existing field, you will get an error and the field will not be created.
295 my $f1 = $table->add_field(
297 data_type => 'integer',
301 my $f2 = SQL::Translator::Schema::Field->new(
305 $f2 = $table->add_field( $field2 ) or die $table->error;
310 my $field_class = 'SQL::Translator::Schema::Field';
313 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
315 $field->table( $self );
319 $args{'table'} = $self;
320 $field = $field_class->new( \%args ) or return
321 $self->error( $field_class->error );
324 $field->order( ++$FIELD_ORDER );
325 # We know we have a name as the Field->new above errors if none given.
326 my $field_name = $field->name;
328 if ( exists $self->{'fields'}{ $field_name } ) {
329 return $self->error(qq[Can't create field: "$field_name" exists]);
332 $self->{'fields'}{ $field_name } = $field;
337 # ----------------------------------------------------------------------
344 Remove a field from the table. Returns the field object if the field was
345 found and removed, an error otherwise. The single parameter can be either
346 a field name or an C<SQL::Translator::Schema::Field> object.
348 $table->drop_field('myfield');
353 my $field_class = 'SQL::Translator::Schema::Field';
356 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
357 $field_name = shift->name;
363 my $cascade = $args{'cascade'};
365 if ( ! exists $self->{'fields'}{ $field_name } ) {
366 return $self->error(qq[Can't drop field: "$field_name" doesn't exists]);
369 my $field = delete $self->{'fields'}{ $field_name };
372 # Remove this field from all indices using it
373 foreach my $i ($self->get_indices()) {
374 my @fs = $i->fields();
375 @fs = grep { $_ ne $field->name } @fs;
379 # Remove this field from all constraints using it
380 foreach my $c ($self->get_constraints()) {
381 my @cs = $c->fields();
382 @cs = grep { $_ ne $field->name } @cs;
390 # ----------------------------------------------------------------------
397 Get or set the comments on a table. May be called several times to
398 set and it will accumulate the comments. Called in an array context,
399 returns each comment individually; called in a scalar context, returns
400 all the comments joined on newlines.
402 $table->comments('foo');
403 $table->comments('bar');
404 print join( ', ', $table->comments ); # prints "foo, bar"
409 my @comments = ref $_[0] ? @{ $_[0] } : @_;
411 for my $arg ( @comments ) {
412 $arg = $arg->[0] if ref $arg;
413 push @{ $self->{'comments'} }, $arg if defined $arg && $arg;
416 if ( @{ $self->{'comments'} || [] } ) {
418 ? @{ $self->{'comments'} }
419 : join( "\n", @{ $self->{'comments'} } )
423 return wantarray ? () : undef;
427 # ----------------------------------------------------------------------
428 sub get_constraints {
432 =head2 get_constraints
434 Returns all the constraint objects as an array or array reference.
436 my @constraints = $table->get_constraints;
442 if ( ref $self->{'constraints'} ) {
444 ? @{ $self->{'constraints'} } : $self->{'constraints'};
447 $self->error('No constraints');
448 return wantarray ? () : undef;
452 # ----------------------------------------------------------------------
459 Returns all the index objects as an array or array reference.
461 my @indices = $table->get_indices;
467 if ( ref $self->{'indices'} ) {
469 ? @{ $self->{'indices'} }
470 : $self->{'indices'};
473 $self->error('No indices');
474 return wantarray ? () : undef;
478 # ----------------------------------------------------------------------
485 Returns a field by the name provided.
487 my $field = $table->get_field('foo');
492 my $field_name = shift or return $self->error('No field name');
493 return $self->error( qq[Field "$field_name" does not exist] ) unless
494 exists $self->{'fields'}{ $field_name };
495 return $self->{'fields'}{ $field_name };
498 # ----------------------------------------------------------------------
505 Returns all the field objects as an array or array reference.
507 my @fields = $table->get_fields;
514 sort { $a->[0] <=> $b->[0] }
515 map { [ $_->order, $_ ] }
516 values %{ $self->{'fields'} || {} };
519 return wantarray ? @fields : \@fields;
522 $self->error('No fields');
523 return wantarray ? () : undef;
527 # ----------------------------------------------------------------------
534 Determine whether the view is valid or not.
536 my $ok = $view->is_valid;
541 return $self->error('No name') unless $self->name;
542 return $self->error('No fields') unless $self->get_fields;
545 $self->get_fields, $self->get_indices, $self->get_constraints
547 return $object->error unless $object->is_valid;
553 # ----------------------------------------------------------------------
554 sub is_trivial_link {
558 =head2 is_trivial_link
560 True if table has no data (non-key) fields and only uses single key joins.
565 return 0 if $self->is_data;
566 return $self->{'is_trivial_link'} if defined $self->{'is_trivial_link'};
568 $self->{'is_trivial_link'} = 1;
572 foreach my $field ( $self->get_fields ) {
573 next unless $field->is_foreign_key;
574 $fk{$field->foreign_key_reference->reference_table}++;
577 foreach my $referenced (keys %fk){
578 if($fk{$referenced} > 1){
579 $self->{'is_trivial_link'} = 0;
584 return $self->{'is_trivial_link'};
594 Returns true if the table has some non-key fields.
599 return $self->{'is_data'} if defined $self->{'is_data'};
601 $self->{'is_data'} = 0;
603 foreach my $field ( $self->get_fields ) {
604 if ( !$field->is_primary_key and !$field->is_foreign_key ) {
605 $self->{'is_data'} = 1;
606 return $self->{'is_data'};
610 return $self->{'is_data'};
613 # ----------------------------------------------------------------------
620 Determine whether the table can link two arg tables via many-to-many.
622 my $ok = $table->can_link($table1,$table2);
626 my ( $self, $table1, $table2 ) = @_;
628 return $self->{'can_link'}{ $table1->name }{ $table2->name }
629 if defined $self->{'can_link'}{ $table1->name }{ $table2->name };
631 if ( $self->is_data == 1 ) {
632 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
633 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
634 return $self->{'can_link'}{ $table1->name }{ $table2->name };
639 foreach my $field ( $self->get_fields ) {
640 if ( $field->is_foreign_key ) {
641 push @{ $fk{ $field->foreign_key_reference->reference_table } },
642 $field->foreign_key_reference;
646 if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
648 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
649 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
650 return $self->{'can_link'}{ $table1->name }{ $table2->name };
653 # trivial traversal, only one way to link the two tables
654 if ( scalar( @{ $fk{ $table1->name } } == 1 )
655 and scalar( @{ $fk{ $table2->name } } == 1 ) )
657 $self->{'can_link'}{ $table1->name }{ $table2->name } =
658 [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
659 $self->{'can_link'}{ $table1->name }{ $table2->name } =
660 [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
662 # non-trivial traversal. one way to link table2,
663 # many ways to link table1
665 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
666 and scalar( @{ $fk{ $table2->name } } == 1 ) )
668 $self->{'can_link'}{ $table1->name }{ $table2->name } =
669 [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
670 $self->{'can_link'}{ $table2->name }{ $table1->name } =
671 [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
673 # non-trivial traversal. one way to link table1,
674 # many ways to link table2
676 elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
677 and scalar( @{ $fk{ $table2->name } } > 1 ) )
679 $self->{'can_link'}{ $table1->name }{ $table2->name } =
680 [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
681 $self->{'can_link'}{ $table2->name }{ $table1->name } =
682 [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
684 # non-trivial traversal. many ways to link table1 and table2
686 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
687 and scalar( @{ $fk{ $table2->name } } > 1 ) )
689 $self->{'can_link'}{ $table1->name }{ $table2->name } =
690 [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
691 $self->{'can_link'}{ $table2->name }{ $table1->name } =
692 [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
694 # one of the tables didn't export a key
695 # to this table, no linking possible
698 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
699 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
702 return $self->{'can_link'}{ $table1->name }{ $table2->name };
705 # ----------------------------------------------------------------------
712 Get or set the table's name.
714 Errors ("No table name") if you try to set a blank name.
716 If provided an argument, checks the schema object for a table of
717 that name and disallows the change if one exists (setting the error to
718 "Can't use table name "%s": table exists").
720 my $table_name = $table->name('foo');
727 my $arg = shift || return $self->error( "No table name" );
728 if ( my $schema = $self->schema ) {
729 return $self->error( qq[Can't use table name "$arg": table exists] )
730 if $schema->get_table( $arg );
732 $self->{'name'} = $arg;
735 return $self->{'name'} || '';
738 # ----------------------------------------------------------------------
745 Get or set the table's schema object.
747 my $schema = $table->schema;
752 if ( my $arg = shift ) {
753 return $self->error('Not a schema object') unless
754 UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
755 $self->{'schema'} = $arg;
758 return $self->{'schema'};
761 # ----------------------------------------------------------------------
768 Gets or sets the table's primary key(s). Takes one or more field
769 names (as a string, list or array[ref]) as an argument. If the field
770 names are present, it will create a new PK if none exists, or it will
771 add to the fields of an existing PK (and will unique the field names).
772 Returns the C<SQL::Translator::Schema::Constraint> object representing
777 $table->primary_key('id');
778 $table->primary_key(['name']);
779 $table->primary_key('id','name']);
780 $table->primary_key(['id','name']);
781 $table->primary_key('id,name');
782 $table->primary_key(qw[ id name ]);
784 my $pk = $table->primary_key;
789 my $fields = parse_list_arg( @_ );
793 for my $f ( @$fields ) {
794 return $self->error(qq[Invalid field "$f"]) unless
795 $self->get_field($f);
799 for my $c ( $self->get_constraints ) {
800 if ( $c->type eq PRIMARY_KEY ) {
802 $c->fields( @{ $c->fields }, @$fields );
808 $constraint = $self->add_constraint(
819 for my $c ( $self->get_constraints ) {
820 return $c if $c->type eq PRIMARY_KEY;
827 # ----------------------------------------------------------------------
834 Get or set the table's options (e.g., table types for MySQL). Returns
835 an array or array reference.
837 my @options = $table->options;
842 my $options = parse_list_arg( @_ );
844 push @{ $self->{'options'} }, @$options;
846 if ( ref $self->{'options'} ) {
847 return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
850 return wantarray ? () : [];
854 # ----------------------------------------------------------------------
861 Get or set the table's order.
863 my $order = $table->order(3);
867 my ( $self, $arg ) = @_;
869 if ( defined $arg && $arg =~ /^\d+$/ ) {
870 $self->{'order'} = $arg;
873 return $self->{'order'} || 0;
876 # ----------------------------------------------------------------------
881 Read-only method to return a list or array ref of the field names. Returns undef
882 or an empty list if the table has no fields set. Usefull if you want to
883 avoid the overload magic of the Field objects returned by the get_fields method.
885 my @names = $constraint->field_names;
892 sort { $a->order <=> $b->order }
893 values %{ $self->{'fields'} || {} };
896 return wantarray ? @fields : \@fields;
899 $self->error('No fields');
900 return wantarray ? () : undef;
904 # ----------------------------------------------------------------------
911 Determines if this table is the same as another
913 my $isIdentical = $table1->equals( $table2 );
920 return 0 unless $self->SUPER::equals($other);
921 return 0 unless $self->name eq $other->name;
922 return 0 unless $self->_compare_objects($self->options, $other->options);
923 return 0 unless $self->_compare_objects($self->extra, $other->extra);
926 # Go through our fields
928 foreach my $field ( $self->get_fields ) {
929 my $otherField = $other->get_field($field->name);
930 return 0 unless $field->equals($otherField);
931 $checkedFields{$field->name} = 1;
933 # Go through the other table's fields
934 foreach my $otherField ( $other->get_fields ) {
935 next if $checkedFields{$otherField->name};
940 # Go through our constraints
941 my %checkedConstraints;
943 foreach my $constraint ( $self->get_constraints ) {
944 foreach my $otherConstraint ( $other->get_constraints ) {
945 if ( $constraint->equals($otherConstraint) ) {
946 $checkedConstraints{$otherConstraint} = 1;
952 # Go through the other table's constraints
953 foreach my $otherConstraint ( $other->get_constraints ) {
954 next if $checkedFields{$otherConstraint};
959 # Go through our indices
962 foreach my $index ( $self->get_indices ) {
963 foreach my $otherIndex ( $other->get_indices ) {
964 if ( $index->equals($otherIndex) ) {
965 $checkedIndices{$otherIndex} = 1;
971 # Go through the other table's constraints
972 foreach my $otherIndex ( $other->get_indices ) {
973 next if $checkedIndices{$otherIndex};
980 # ----------------------------------------------------------------------
982 =head1 LOOKUP METHODS
984 The following are a set of shortcut methods for getting commonly used lists of
985 fields and constraints. They all return lists or array refs of Field or
992 The primary key fields.
996 All foreign key fields.
1000 All the fields except the primary key.
1008 All fields with unique constraints.
1010 =item unique_constraints
1012 All this tables unique constraints.
1014 =item fkey_constraints
1016 All this tables foreign key constraints. (See primary_key method to get the
1017 primary key constraint)
1025 my @fields = grep { $_->is_primary_key } $me->get_fields;
1026 return wantarray ? @fields : \@fields;
1029 # ----------------------------------------------------------------------
1033 push @fields, $_->fields foreach $me->fkey_constraints;
1034 return wantarray ? @fields : \@fields;
1037 # ----------------------------------------------------------------------
1038 sub nonpkey_fields {
1040 my @fields = grep { !$_->is_primary_key } $me->get_fields;
1041 return wantarray ? @fields : \@fields;
1044 # ----------------------------------------------------------------------
1048 grep { !$_->is_foreign_key and !$_->is_primary_key } $me->get_fields;
1049 return wantarray ? @fields : \@fields;
1052 # ----------------------------------------------------------------------
1056 push @fields, $_->fields foreach $me->unique_constraints;
1057 return wantarray ? @fields : \@fields;
1060 # ----------------------------------------------------------------------
1061 sub unique_constraints {
1063 my @cons = grep { $_->type eq UNIQUE } $me->get_constraints;
1064 return wantarray ? @cons : \@cons;
1067 # ----------------------------------------------------------------------
1068 sub fkey_constraints {
1070 my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints;
1071 return wantarray ? @cons : \@cons;
1074 # ----------------------------------------------------------------------
1077 undef $self->{'schema'}; # destroy cyclical reference
1078 undef $_ for @{ $self->{'constraints'} };
1079 undef $_ for @{ $self->{'indices'} };
1080 undef $_ for values %{ $self->{'fields'} };
1085 # ----------------------------------------------------------------------
1091 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
1092 Allen Day E<lt>allenday@ucla.eduE<gt>.