1 package SQL::Translator::Schema::Table;
3 # ----------------------------------------------------------------------
4 # $Id: Table.pm,v 1.37 2007-10-24 10:55:44 schiffbruechige 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.27 $ =~ /(\d+)\.(\d+)/;
56 # Stringify to our name, being careful not to pass any args through so we don't
57 # accidentally set it to undef. We also have to tweak bool so the object is
58 # still true when it doesn't have a name (which shouldn't happen!).
60 '""' => sub { shift->name },
61 'bool' => sub { $_[0]->name || $_[0] },
65 # ----------------------------------------------------------------------
67 __PACKAGE__->_attributes( qw/schema name comments options order/ );
75 my $table = SQL::Translator::Schema::Table->new(
82 # ----------------------------------------------------------------------
89 Add a constraint to the table. Returns the newly created
90 C<SQL::Translator::Schema::Constraint> object.
92 my $c1 = $table->add_constraint(
95 fields => [ 'foo_id' ],
98 my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
99 $c2 = $table->add_constraint( $constraint );
104 my $constraint_class = 'SQL::Translator::Schema::Constraint';
107 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
109 $constraint->table( $self );
113 $args{'table'} = $self;
114 $constraint = $constraint_class->new( \%args ) or
115 return $self->error( $constraint_class->error );
119 # If we're trying to add a PK when one is already defined,
120 # then just add the fields to the existing definition.
123 my $pk = $self->primary_key;
124 if ( $pk && $constraint->type eq PRIMARY_KEY ) {
125 $self->primary_key( $constraint->fields );
126 $pk->name($constraint->name) if $constraint->name;
127 my %extra = $constraint->extra;
128 $pk->extra(%extra) if keys %extra;
132 elsif ( $constraint->type eq PRIMARY_KEY ) {
133 for my $fname ( $constraint->fields ) {
134 if ( my $f = $self->get_field( $fname ) ) {
135 $f->is_primary_key( 1 );
140 # See if another constraint of the same type
141 # covers the same fields. -- This doesn't work! ky
143 # elsif ( $constraint->type ne CHECK_C ) {
144 # my @field_names = $constraint->fields;
146 # grep { $_->type eq $constraint->type }
147 # $self->get_constraints
149 # my %fields = map { $_, 1 } $c->fields;
150 # for my $field_name ( @field_names ) {
151 # if ( $fields{ $field_name } ) {
162 push @{ $self->{'constraints'} }, $constraint;
168 # ----------------------------------------------------------------------
169 sub drop_constraint {
173 =head2 drop_constraint
175 Remove a constraint from the table. Returns the constraint object if the index
176 was found and removed, an error otherwise. The single parameter can be either
177 an index name or an C<SQL::Translator::Schema::Constraint> object.
179 $table->drop_constraint('myconstraint');
184 my $constraint_class = 'SQL::Translator::Schema::Constraint';
187 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
188 $constraint_name = shift->name;
191 $constraint_name = shift;
194 if ( ! grep { $_->name eq $constraint_name } @ { $self->{'constraints'} } ) {
195 return $self->error(qq[Can't drop constraint: "$constraint_name" doesn't exist]);
198 my @cs = @{ $self->{'constraints'} };
199 my ($constraint_id) = grep { $cs[$_]->name eq $constraint_name } (0..$#cs);
200 my $constraint = splice(@{$self->{'constraints'}}, $constraint_id, 1);
205 # ----------------------------------------------------------------------
212 Add an index to the table. Returns the newly created
213 C<SQL::Translator::Schema::Index> object.
215 my $i1 = $table->add_index(
217 fields => [ 'name' ],
221 my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
222 $i2 = $table->add_index( $index );
227 my $index_class = 'SQL::Translator::Schema::Index';
230 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
232 $index->table( $self );
236 $args{'table'} = $self;
237 $index = $index_class->new( \%args ) or return
238 $self->error( $index_class->error );
240 foreach my $ex_index ($self->get_indices) {
241 return if ($ex_index->equals($index));
243 push @{ $self->{'indices'} }, $index;
247 # ----------------------------------------------------------------------
254 Remove an index from the table. Returns the index object if the index was
255 found and removed, an error otherwise. The single parameter can be either
256 an index name of an C<SQL::Translator::Schema::Index> object.
258 $table->drop_index('myindex');
263 my $index_class = 'SQL::Translator::Schema::Index';
266 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
267 $index_name = shift->name;
273 if ( ! grep { $_->name eq $index_name } @{ $self->{'indices'} }) {
274 return $self->error(qq[Can't drop index: "$index_name" doesn't exist]);
277 my @is = @{ $self->{'indices'} };
278 my ($index_id) = grep { $is[$_]->name eq $index_name } (0..$#is);
279 my $index = splice(@{$self->{'indices'}}, $index_id, 1);
284 # ----------------------------------------------------------------------
291 Add an field to the table. Returns the newly created
292 C<SQL::Translator::Schema::Field> object. The "name" parameter is
293 required. If you try to create a field with the same name as an
294 existing field, you will get an error and the field will not be created.
296 my $f1 = $table->add_field(
298 data_type => 'integer',
302 my $f2 = SQL::Translator::Schema::Field->new(
306 $f2 = $table->add_field( $field2 ) or die $table->error;
311 my $field_class = 'SQL::Translator::Schema::Field';
314 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
316 $field->table( $self );
320 $args{'table'} = $self;
321 $field = $field_class->new( \%args ) or return
322 $self->error( $field_class->error );
325 $field->order( ++$FIELD_ORDER );
326 # We know we have a name as the Field->new above errors if none given.
327 my $field_name = $field->name;
329 if ( exists $self->{'fields'}{ $field_name } ) {
330 return $self->error(qq[Can't create field: "$field_name" exists]);
333 $self->{'fields'}{ $field_name } = $field;
338 # ----------------------------------------------------------------------
345 Remove a field from the table. Returns the field object if the field was
346 found and removed, an error otherwise. The single parameter can be either
347 a field name or an C<SQL::Translator::Schema::Field> object.
349 $table->drop_field('myfield');
354 my $field_class = 'SQL::Translator::Schema::Field';
357 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
358 $field_name = shift->name;
364 my $cascade = $args{'cascade'};
366 if ( ! exists $self->{'fields'}{ $field_name } ) {
367 return $self->error(qq[Can't drop field: "$field_name" doesn't exists]);
370 my $field = delete $self->{'fields'}{ $field_name };
373 # Remove this field from all indices using it
374 foreach my $i ($self->get_indices()) {
375 my @fs = $i->fields();
376 @fs = grep { $_ ne $field->name } @fs;
380 # Remove this field from all constraints using it
381 foreach my $c ($self->get_constraints()) {
382 my @cs = $c->fields();
383 @cs = grep { $_ ne $field->name } @cs;
391 # ----------------------------------------------------------------------
398 Get or set the comments on a table. May be called several times to
399 set and it will accumulate the comments. Called in an array context,
400 returns each comment individually; called in a scalar context, returns
401 all the comments joined on newlines.
403 $table->comments('foo');
404 $table->comments('bar');
405 print join( ', ', $table->comments ); # prints "foo, bar"
410 my @comments = ref $_[0] ? @{ $_[0] } : @_;
412 for my $arg ( @comments ) {
413 $arg = $arg->[0] if ref $arg;
414 push @{ $self->{'comments'} }, $arg if defined $arg && $arg;
417 if ( @{ $self->{'comments'} || [] } ) {
419 ? @{ $self->{'comments'} }
420 : join( "\n", @{ $self->{'comments'} } )
424 return wantarray ? () : undef;
428 # ----------------------------------------------------------------------
429 sub get_constraints {
433 =head2 get_constraints
435 Returns all the constraint objects as an array or array reference.
437 my @constraints = $table->get_constraints;
443 if ( ref $self->{'constraints'} ) {
445 ? @{ $self->{'constraints'} } : $self->{'constraints'};
448 $self->error('No constraints');
449 return wantarray ? () : undef;
453 # ----------------------------------------------------------------------
460 Returns all the index objects as an array or array reference.
462 my @indices = $table->get_indices;
468 if ( ref $self->{'indices'} ) {
470 ? @{ $self->{'indices'} }
471 : $self->{'indices'};
474 $self->error('No indices');
475 return wantarray ? () : undef;
479 # ----------------------------------------------------------------------
486 Returns a field by the name provided.
488 my $field = $table->get_field('foo');
493 my $field_name = shift or return $self->error('No field name');
494 my $case_insensitive = shift;
495 if ( $case_insensitive ) {
496 $field_name = uc($field_name);
497 foreach my $field ( keys %{$self->{fields}} ) {
498 return $self->{fields}{$field} if $field_name eq uc($field);
500 return $self->error(qq[Field "$field_name" does not exist]);
502 return $self->error( qq[Field "$field_name" does not exist] ) unless
503 exists $self->{'fields'}{ $field_name };
504 return $self->{'fields'}{ $field_name };
507 # ----------------------------------------------------------------------
514 Returns all the field objects as an array or array reference.
516 my @fields = $table->get_fields;
523 sort { $a->[0] <=> $b->[0] }
524 map { [ $_->order, $_ ] }
525 values %{ $self->{'fields'} || {} };
528 return wantarray ? @fields : \@fields;
531 $self->error('No fields');
532 return wantarray ? () : undef;
536 # ----------------------------------------------------------------------
543 Determine whether the view is valid or not.
545 my $ok = $view->is_valid;
550 return $self->error('No name') unless $self->name;
551 return $self->error('No fields') unless $self->get_fields;
554 $self->get_fields, $self->get_indices, $self->get_constraints
556 return $object->error unless $object->is_valid;
562 # ----------------------------------------------------------------------
563 sub is_trivial_link {
567 =head2 is_trivial_link
569 True if table has no data (non-key) fields and only uses single key joins.
574 return 0 if $self->is_data;
575 return $self->{'is_trivial_link'} if defined $self->{'is_trivial_link'};
577 $self->{'is_trivial_link'} = 1;
581 foreach my $field ( $self->get_fields ) {
582 next unless $field->is_foreign_key;
583 $fk{$field->foreign_key_reference->reference_table}++;
586 foreach my $referenced (keys %fk){
587 if($fk{$referenced} > 1){
588 $self->{'is_trivial_link'} = 0;
593 return $self->{'is_trivial_link'};
603 Returns true if the table has some non-key fields.
608 return $self->{'is_data'} if defined $self->{'is_data'};
610 $self->{'is_data'} = 0;
612 foreach my $field ( $self->get_fields ) {
613 if ( !$field->is_primary_key and !$field->is_foreign_key ) {
614 $self->{'is_data'} = 1;
615 return $self->{'is_data'};
619 return $self->{'is_data'};
622 # ----------------------------------------------------------------------
629 Determine whether the table can link two arg tables via many-to-many.
631 my $ok = $table->can_link($table1,$table2);
635 my ( $self, $table1, $table2 ) = @_;
637 return $self->{'can_link'}{ $table1->name }{ $table2->name }
638 if defined $self->{'can_link'}{ $table1->name }{ $table2->name };
640 if ( $self->is_data == 1 ) {
641 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
642 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
643 return $self->{'can_link'}{ $table1->name }{ $table2->name };
648 foreach my $field ( $self->get_fields ) {
649 if ( $field->is_foreign_key ) {
650 push @{ $fk{ $field->foreign_key_reference->reference_table } },
651 $field->foreign_key_reference;
655 if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
657 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
658 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
659 return $self->{'can_link'}{ $table1->name }{ $table2->name };
662 # trivial traversal, only one way to link the two tables
663 if ( scalar( @{ $fk{ $table1->name } } == 1 )
664 and scalar( @{ $fk{ $table2->name } } == 1 ) )
666 $self->{'can_link'}{ $table1->name }{ $table2->name } =
667 [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
668 $self->{'can_link'}{ $table1->name }{ $table2->name } =
669 [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
671 # non-trivial traversal. one way to link table2,
672 # many ways to link table1
674 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
675 and scalar( @{ $fk{ $table2->name } } == 1 ) )
677 $self->{'can_link'}{ $table1->name }{ $table2->name } =
678 [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
679 $self->{'can_link'}{ $table2->name }{ $table1->name } =
680 [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
682 # non-trivial traversal. one way to link table1,
683 # many ways to link table2
685 elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
686 and scalar( @{ $fk{ $table2->name } } > 1 ) )
688 $self->{'can_link'}{ $table1->name }{ $table2->name } =
689 [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
690 $self->{'can_link'}{ $table2->name }{ $table1->name } =
691 [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
693 # non-trivial traversal. many ways to link table1 and table2
695 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
696 and scalar( @{ $fk{ $table2->name } } > 1 ) )
698 $self->{'can_link'}{ $table1->name }{ $table2->name } =
699 [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
700 $self->{'can_link'}{ $table2->name }{ $table1->name } =
701 [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
703 # one of the tables didn't export a key
704 # to this table, no linking possible
707 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
708 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
711 return $self->{'can_link'}{ $table1->name }{ $table2->name };
714 # ----------------------------------------------------------------------
721 Get or set the table's name.
723 Errors ("No table name") if you try to set a blank name.
725 If provided an argument, checks the schema object for a table of
726 that name and disallows the change if one exists (setting the error to
727 "Can't use table name "%s": table exists").
729 my $table_name = $table->name('foo');
736 my $arg = shift || return $self->error( "No table name" );
737 if ( my $schema = $self->schema ) {
738 return $self->error( qq[Can't use table name "$arg": table exists] )
739 if $schema->get_table( $arg );
741 $self->{'name'} = $arg;
744 return $self->{'name'} || '';
747 # ----------------------------------------------------------------------
754 Get or set the table's schema object.
756 my $schema = $table->schema;
761 if ( my $arg = shift ) {
762 return $self->error('Not a schema object') unless
763 UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
764 $self->{'schema'} = $arg;
767 return $self->{'schema'};
770 # ----------------------------------------------------------------------
777 Gets or sets the table's primary key(s). Takes one or more field
778 names (as a string, list or array[ref]) as an argument. If the field
779 names are present, it will create a new PK if none exists, or it will
780 add to the fields of an existing PK (and will unique the field names).
781 Returns the C<SQL::Translator::Schema::Constraint> object representing
786 $table->primary_key('id');
787 $table->primary_key(['name']);
788 $table->primary_key('id','name']);
789 $table->primary_key(['id','name']);
790 $table->primary_key('id,name');
791 $table->primary_key(qw[ id name ]);
793 my $pk = $table->primary_key;
798 my $fields = parse_list_arg( @_ );
802 for my $f ( @$fields ) {
803 return $self->error(qq[Invalid field "$f"]) unless
804 $self->get_field($f);
808 for my $c ( $self->get_constraints ) {
809 if ( $c->type eq PRIMARY_KEY ) {
811 $c->fields( @{ $c->fields }, @$fields );
817 $constraint = $self->add_constraint(
828 for my $c ( $self->get_constraints ) {
829 return $c if $c->type eq PRIMARY_KEY;
836 # ----------------------------------------------------------------------
843 Get or set the table's options (e.g., table types for MySQL). Returns
844 an array or array reference.
846 my @options = $table->options;
851 my $options = parse_list_arg( @_ );
853 push @{ $self->{'options'} }, @$options;
855 if ( ref $self->{'options'} ) {
856 return wantarray ? @{ $self->{'options'} || [] } : ($self->{'options'} || '');
859 return wantarray ? () : [];
863 # ----------------------------------------------------------------------
870 Get or set the table's order.
872 my $order = $table->order(3);
876 my ( $self, $arg ) = @_;
878 if ( defined $arg && $arg =~ /^\d+$/ ) {
879 $self->{'order'} = $arg;
882 return $self->{'order'} || 0;
885 # ----------------------------------------------------------------------
890 Read-only method to return a list or array ref of the field names. Returns undef
891 or an empty list if the table has no fields set. Usefull if you want to
892 avoid the overload magic of the Field objects returned by the get_fields method.
894 my @names = $constraint->field_names;
901 sort { $a->order <=> $b->order }
902 values %{ $self->{'fields'} || {} };
905 return wantarray ? @fields : \@fields;
908 $self->error('No fields');
909 return wantarray ? () : undef;
913 # ----------------------------------------------------------------------
920 Determines if this table is the same as another
922 my $isIdentical = $table1->equals( $table2 );
928 my $case_insensitive = shift;
930 return 0 unless $self->SUPER::equals($other);
931 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
932 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
933 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
936 # Go through our fields
938 foreach my $field ( $self->get_fields ) {
939 my $otherField = $other->get_field($field->name, $case_insensitive);
940 return 0 unless $field->equals($otherField, $case_insensitive);
941 $checkedFields{$field->name} = 1;
943 # Go through the other table's fields
944 foreach my $otherField ( $other->get_fields ) {
945 next if $checkedFields{$otherField->name};
950 # Go through our constraints
951 my %checkedConstraints;
953 foreach my $constraint ( $self->get_constraints ) {
954 foreach my $otherConstraint ( $other->get_constraints ) {
955 if ( $constraint->equals($otherConstraint, $case_insensitive) ) {
956 $checkedConstraints{$otherConstraint} = 1;
962 # Go through the other table's constraints
964 foreach my $otherConstraint ( $other->get_constraints ) {
965 next if $checkedFields{$otherConstraint};
966 foreach my $constraint ( $self->get_constraints ) {
967 if ( $otherConstraint->equals($constraint, $case_insensitive) ) {
975 # Go through our indices
978 foreach my $index ( $self->get_indices ) {
979 foreach my $otherIndex ( $other->get_indices ) {
980 if ( $index->equals($otherIndex, $case_insensitive) ) {
981 $checkedIndices{$otherIndex} = 1;
987 # Go through the other table's indices
989 foreach my $otherIndex ( $other->get_indices ) {
990 next if $checkedIndices{$otherIndex};
991 foreach my $index ( $self->get_indices ) {
992 if ( $otherIndex->equals($index, $case_insensitive) ) {
1002 # ----------------------------------------------------------------------
1004 =head1 LOOKUP METHODS
1006 The following are a set of shortcut methods for getting commonly used lists of
1007 fields and constraints. They all return lists or array refs of Field or
1014 The primary key fields.
1018 All foreign key fields.
1020 =item nonpkey_fields
1022 All the fields except the primary key.
1030 All fields with unique constraints.
1032 =item unique_constraints
1034 All this tables unique constraints.
1036 =item fkey_constraints
1038 All this tables foreign key constraints. (See primary_key method to get the
1039 primary key constraint)
1047 my @fields = grep { $_->is_primary_key } $me->get_fields;
1048 return wantarray ? @fields : \@fields;
1051 # ----------------------------------------------------------------------
1055 push @fields, $_->fields foreach $me->fkey_constraints;
1056 return wantarray ? @fields : \@fields;
1059 # ----------------------------------------------------------------------
1060 sub nonpkey_fields {
1062 my @fields = grep { !$_->is_primary_key } $me->get_fields;
1063 return wantarray ? @fields : \@fields;
1066 # ----------------------------------------------------------------------
1070 grep { !$_->is_foreign_key and !$_->is_primary_key } $me->get_fields;
1071 return wantarray ? @fields : \@fields;
1074 # ----------------------------------------------------------------------
1078 push @fields, $_->fields foreach $me->unique_constraints;
1079 return wantarray ? @fields : \@fields;
1082 # ----------------------------------------------------------------------
1083 sub unique_constraints {
1085 my @cons = grep { $_->type eq UNIQUE } $me->get_constraints;
1086 return wantarray ? @cons : \@cons;
1089 # ----------------------------------------------------------------------
1090 sub fkey_constraints {
1092 my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints;
1093 return wantarray ? @cons : \@cons;
1096 # ----------------------------------------------------------------------
1099 undef $self->{'schema'}; # destroy cyclical reference
1100 undef $_ for @{ $self->{'constraints'} };
1101 undef $_ for @{ $self->{'indices'} };
1102 undef $_ for values %{ $self->{'fields'} };
1107 # ----------------------------------------------------------------------
1113 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
1114 Allen Day E<lt>allenday@ucla.eduE<gt>.