1 package SQL::Translator::Schema::Table;
7 SQL::Translator::Schema::Table - SQL::Translator table object
11 use SQL::Translator::Schema::Table;
12 my $table = SQL::Translator::Schema::Table->new( name => 'foo' );
16 C<SQL::Translator::Schema::Table> is the table object.
23 use SQL::Translator::Utils qw(parse_list_arg ex2err throw);
24 use SQL::Translator::Types qw(schema_obj);
25 use SQL::Translator::Schema::Constants;
26 use SQL::Translator::Schema::Constraint;
27 use SQL::Translator::Schema::Field;
28 use SQL::Translator::Schema::Index;
30 use Carp::Clan '^SQL::Translator';
34 SQL::Translator::Schema::Role::Extra
35 SQL::Translator::Schema::Role::Error
36 SQL::Translator::Schema::Role::Compare
39 our $VERSION = '1.59';
41 # Stringify to our name, being careful not to pass any args through so we don't
42 # accidentally set it to undef. We also have to tweak bool so the object is
43 # still true when it doesn't have a name (which shouldn't happen!).
45 '""' => sub { shift->name },
46 'bool' => sub { $_[0]->name || $_[0] },
56 my $table = SQL::Translator::Schema::Table->new(
63 Add a constraint to the table. Returns the newly created
64 C<SQL::Translator::Schema::Constraint> object.
66 my $c1 = $table->add_constraint(
69 fields => [ 'foo_id' ],
72 my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
73 $c2 = $table->add_constraint( $constraint );
80 default => sub { +[] },
87 my $constraint_class = 'SQL::Translator::Schema::Constraint';
90 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
92 $constraint->table( $self );
96 $args{'table'} = $self;
97 $constraint = $constraint_class->new( \%args ) or
98 return $self->error( $constraint_class->error );
102 # If we're trying to add a PK when one is already defined,
103 # then just add the fields to the existing definition.
106 my $pk = $self->primary_key;
107 if ( $pk && $constraint->type eq PRIMARY_KEY ) {
108 $self->primary_key( $constraint->fields );
109 $pk->name($constraint->name) if $constraint->name;
110 my %extra = $constraint->extra;
111 $pk->extra(%extra) if keys %extra;
115 elsif ( $constraint->type eq PRIMARY_KEY ) {
116 for my $fname ( $constraint->fields ) {
117 if ( my $f = $self->get_field( $fname ) ) {
118 $f->is_primary_key( 1 );
123 # See if another constraint of the same type
124 # covers the same fields. -- This doesn't work! ky
126 # elsif ( $constraint->type ne CHECK_C ) {
127 # my @field_names = $constraint->fields;
129 # grep { $_->type eq $constraint->type }
130 # $self->get_constraints
132 # my %fields = map { $_, 1 } $c->fields;
133 # for my $field_name ( @field_names ) {
134 # if ( $fields{ $field_name } ) {
145 push @{ $self->_constraints }, $constraint;
151 =head2 drop_constraint
153 Remove a constraint from the table. Returns the constraint object if the index
154 was found and removed, an error otherwise. The single parameter can be either
155 an index name or an C<SQL::Translator::Schema::Constraint> object.
157 $table->drop_constraint('myconstraint');
161 sub drop_constraint {
163 my $constraint_class = 'SQL::Translator::Schema::Constraint';
166 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
167 $constraint_name = shift->name;
170 $constraint_name = shift;
173 if ( ! ($self->_has_constraints && grep { $_->name eq $constraint_name } @ { $self->_constraints }) ) {
174 return $self->error(qq[Can't drop constraint: "$constraint_name" doesn't exist]);
177 my @cs = @{ $self->_constraints };
178 my ($constraint_id) = grep { $cs[$_]->name eq $constraint_name } (0..$#cs);
179 my $constraint = splice(@{$self->_constraints}, $constraint_id, 1);
186 Add an index to the table. Returns the newly created
187 C<SQL::Translator::Schema::Index> object.
189 my $i1 = $table->add_index(
191 fields => [ 'name' ],
195 my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
196 $i2 = $table->add_index( $index );
203 default => sub { [] },
210 my $index_class = 'SQL::Translator::Schema::Index';
213 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
215 $index->table( $self );
219 $args{'table'} = $self;
220 $index = $index_class->new( \%args ) or return
221 $self->error( $index_class->error );
223 foreach my $ex_index ($self->get_indices) {
224 return if ($ex_index->equals($index));
226 push @{ $self->_indices }, $index;
232 Remove an index from the table. Returns the index object if the index was
233 found and removed, an error otherwise. The single parameter can be either
234 an index name of an C<SQL::Translator::Schema::Index> object.
236 $table->drop_index('myindex');
242 my $index_class = 'SQL::Translator::Schema::Index';
245 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
246 $index_name = shift->name;
252 if ( ! ($self->_has_indices && grep { $_->name eq $index_name } @{ $self->_indices }) ) {
253 return $self->error(qq[Can't drop index: "$index_name" doesn't exist]);
256 my @is = @{ $self->_indices };
257 my ($index_id) = grep { $is[$_]->name eq $index_name } (0..$#is);
258 my $index = splice(@{$self->_indices}, $index_id, 1);
265 Add an field to the table. Returns the newly created
266 C<SQL::Translator::Schema::Field> object. The "name" parameter is
267 required. If you try to create a field with the same name as an
268 existing field, you will get an error and the field will not be created.
270 my $f1 = $table->add_field(
272 data_type => 'integer',
276 my $f2 = SQL::Translator::Schema::Field->new(
280 $f2 = $table->add_field( $field2 ) or die $table->error;
287 default => sub { +{} },
294 my $field_class = 'SQL::Translator::Schema::Field';
297 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
299 $field->table( $self );
303 $args{'table'} = $self;
304 $field = $field_class->new( \%args ) or return
305 $self->error( $field_class->error );
308 my $existing_order = { map { $_->order => $_->name } $self->get_fields };
310 # supplied order, possible unordered assembly
311 if ( $field->order ) {
312 if($existing_order->{$field->order}) {
314 "Requested order '%d' for column '%s' conflicts with already existing column '%s'",
317 $existing_order->{$field->order},
322 my $last_field_no = max(keys %$existing_order) || 0;
323 if ( $last_field_no != scalar keys %$existing_order ) {
325 "Table '%s' field order incomplete - unable to auto-determine order for newly added field",
330 $field->order( $last_field_no + 1 );
333 # We know we have a name as the Field->new above errors if none given.
334 my $field_name = $field->name;
336 if ( $self->get_field($field_name) ) {
337 return $self->error(qq[Can't use field name "$field_name": field exists]);
340 $self->_fields->{ $field_name } = $field;
348 Remove a field from the table. Returns the field object if the field was
349 found and removed, an error otherwise. The single parameter can be either
350 a field name or an C<SQL::Translator::Schema::Field> object.
352 $table->drop_field('myfield');
358 my $field_class = 'SQL::Translator::Schema::Field';
361 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
362 $field_name = shift->name;
368 my $cascade = $args{'cascade'};
370 if ( ! ($self->_has_fields && exists $self->_fields->{ $field_name } ) ) {
371 return $self->error(qq[Can't drop field: "$field_name" doesn't exists]);
374 my $field = delete $self->_fields->{ $field_name };
377 # Remove this field from all indices using it
378 foreach my $i ($self->get_indices()) {
379 my @fs = $i->fields();
380 @fs = grep { $_ ne $field->name } @fs;
384 # Remove this field from all constraints using it
385 foreach my $c ($self->get_constraints()) {
386 my @cs = $c->fields();
387 @cs = grep { $_ ne $field->name } @cs;
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"
410 coerce => sub { ref($_[0]) eq 'ARRAY' ? $_[0] : [$_[0]] },
411 default => sub { [] },
414 around comments => sub {
417 my @comments = ref $_[0] ? @{ $_[0] } : @_;
419 for my $arg ( @comments ) {
420 $arg = $arg->[0] if ref $arg;
421 push @{ $self->$orig }, $arg if defined $arg && $arg;
424 @comments = @{$self->$orig};
425 return wantarray ? @comments
426 : @comments ? join( "\n", @comments )
430 =head2 get_constraints
432 Returns all the constraint objects as an array or array reference.
434 my @constraints = $table->get_constraints;
438 sub get_constraints {
441 if ( $self->_has_constraints ) {
443 ? @{ $self->_constraints } : $self->_constraints;
446 $self->error('No constraints');
447 return wantarray ? () : undef;
453 Returns all the index objects as an array or array reference.
455 my @indices = $table->get_indices;
462 if ( $self->_has_indices ) {
464 ? @{ $self->_indices }
468 $self->error('No indices');
469 return wantarray ? () : undef;
475 Returns a field by the name provided.
477 my $field = $table->get_field('foo');
483 my $field_name = shift or return $self->error('No field name');
484 my $case_insensitive = shift;
485 return $self->error(qq[Field "$field_name" does not exist])
486 unless $self->_has_fields;
487 if ( $case_insensitive ) {
488 $field_name = uc($field_name);
489 foreach my $field ( keys %{$self->_fields} ) {
490 return $self->_fields->{$field} if $field_name eq uc($field);
492 return $self->error(qq[Field "$field_name" does not exist]);
494 return $self->error( qq[Field "$field_name" does not exist] ) unless
495 exists $self->_fields->{ $field_name };
496 return $self->_fields->{ $field_name };
501 Returns all the field objects as an array or array reference.
503 my @fields = $table->get_fields;
511 sort { $a->[0] <=> $b->[0] }
512 map { [ $_->order, $_ ] }
513 values %{ $self->_has_fields ? $self->_fields : {} };
516 return wantarray ? @fields : \@fields;
519 $self->error('No fields');
520 return wantarray ? () : undef;
526 Determine whether the view is valid or not.
528 my $ok = $view->is_valid;
534 return $self->error('No name') unless $self->name;
535 return $self->error('No fields') unless $self->get_fields;
538 $self->get_fields, $self->get_indices, $self->get_constraints
540 return $object->error unless $object->is_valid;
546 =head2 is_trivial_link
548 True if table has no data (non-key) fields and only uses single key joins.
552 has is_trivial_link => ( is => 'lazy', init_arg => undef );
554 sub _build_is_trivial_link {
556 return 0 if $self->is_data;
560 foreach my $field ( $self->get_fields ) {
561 next unless $field->is_foreign_key;
562 $fk{$field->foreign_key_reference->reference_table}++;
565 foreach my $referenced (keys %fk){
566 if($fk{$referenced} > 1){
576 Returns true if the table has some non-key fields.
580 has is_data => ( is => 'lazy', init_arg => undef );
585 foreach my $field ( $self->get_fields ) {
586 if ( !$field->is_primary_key and !$field->is_foreign_key ) {
596 Determine whether the table can link two arg tables via many-to-many.
598 my $ok = $table->can_link($table1,$table2);
602 has _can_link => ( is => 'ro', init_arg => undef, default => sub { +{} } );
605 my ( $self, $table1, $table2 ) = @_;
607 return $self->_can_link->{ $table1->name }{ $table2->name }
608 if defined $self->_can_link->{ $table1->name }{ $table2->name };
610 if ( $self->is_data == 1 ) {
611 $self->_can_link->{ $table1->name }{ $table2->name } = [0];
612 $self->_can_link->{ $table2->name }{ $table1->name } = [0];
613 return $self->_can_link->{ $table1->name }{ $table2->name };
618 foreach my $field ( $self->get_fields ) {
619 if ( $field->is_foreign_key ) {
620 push @{ $fk{ $field->foreign_key_reference->reference_table } },
621 $field->foreign_key_reference;
625 if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
627 $self->_can_link->{ $table1->name }{ $table2->name } = [0];
628 $self->_can_link->{ $table2->name }{ $table1->name } = [0];
629 return $self->_can_link->{ $table1->name }{ $table2->name };
632 # trivial traversal, only one way to link the two tables
633 if ( scalar( @{ $fk{ $table1->name } } == 1 )
634 and scalar( @{ $fk{ $table2->name } } == 1 ) )
636 $self->_can_link->{ $table1->name }{ $table2->name } =
637 [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
638 $self->_can_link->{ $table1->name }{ $table2->name } =
639 [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
641 # non-trivial traversal. one way to link table2,
642 # many ways to link table1
644 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
645 and scalar( @{ $fk{ $table2->name } } == 1 ) )
647 $self->_can_link->{ $table1->name }{ $table2->name } =
648 [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
649 $self->_can_link->{ $table2->name }{ $table1->name } =
650 [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
652 # non-trivial traversal. one way to link table1,
653 # many ways to link table2
655 elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
656 and scalar( @{ $fk{ $table2->name } } > 1 ) )
658 $self->_can_link->{ $table1->name }{ $table2->name } =
659 [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
660 $self->_can_link->{ $table2->name }{ $table1->name } =
661 [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
663 # non-trivial traversal. many ways to link table1 and table2
665 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
666 and scalar( @{ $fk{ $table2->name } } > 1 ) )
668 $self->_can_link->{ $table1->name }{ $table2->name } =
669 [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
670 $self->_can_link->{ $table2->name }{ $table1->name } =
671 [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
673 # one of the tables didn't export a key
674 # to this table, no linking possible
677 $self->_can_link->{ $table1->name }{ $table2->name } = [0];
678 $self->_can_link->{ $table2->name }{ $table1->name } = [0];
681 return $self->_can_link->{ $table1->name }{ $table2->name };
686 Get or set the table's name.
688 Errors ("No table name") if you try to set a blank name.
690 If provided an argument, checks the schema object for a table of
691 that name and disallows the change if one exists (setting the error to
692 "Can't use table name "%s": table exists").
694 my $table_name = $table->name('foo');
700 isa => sub { throw("No table name") unless $_[0] },
707 if ( my ($arg) = @_ ) {
708 if ( my $schema = $self->schema ) {
709 return $self->error( qq[Can't use table name "$arg": table exists] )
710 if $schema->get_table( $arg );
714 return ex2err($orig, $self, @_);
719 Get or set the table's schema object.
721 my $schema = $table->schema;
725 has schema => ( is => 'rw', isa => schema_obj('Schema') );
727 around schema => \&ex2err;
735 Gets or sets the table's primary key(s). Takes one or more field
736 names (as a string, list or array[ref]) as an argument. If the field
737 names are present, it will create a new PK if none exists, or it will
738 add to the fields of an existing PK (and will unique the field names).
739 Returns the C<SQL::Translator::Schema::Constraint> object representing
744 $table->primary_key('id');
745 $table->primary_key(['name']);
746 $table->primary_key('id','name']);
747 $table->primary_key(['id','name']);
748 $table->primary_key('id,name');
749 $table->primary_key(qw[ id name ]);
751 my $pk = $table->primary_key;
756 my $fields = parse_list_arg( @_ );
760 for my $f ( @$fields ) {
761 return $self->error(qq[Invalid field "$f"]) unless
762 $self->get_field($f);
766 for my $c ( $self->get_constraints ) {
767 if ( $c->type eq PRIMARY_KEY ) {
769 $c->fields( @{ $c->fields }, @$fields );
775 $constraint = $self->add_constraint(
786 for my $c ( $self->get_constraints ) {
787 return $c if $c->type eq PRIMARY_KEY;
796 Get or set the table's options (e.g., table types for MySQL). Returns
797 an array or array reference.
799 my @options = $table->options;
805 default => sub { [] },
806 coerce => \&parse_list_arg,
809 around options => sub {
812 my $options = parse_list_arg( @_ );
814 push @{ $self->$orig }, @$options;
816 return wantarray ? @{ $self->$orig } : $self->$orig;
821 Get or set the table's order.
823 my $order = $table->order(3);
827 has order => ( is => 'rw', default => sub { 0 } );
829 around order => sub {
830 my ( $orig, $self, $arg ) = @_;
832 if ( defined $arg && $arg =~ /^\d+$/ ) {
833 return $self->$orig($arg);
841 Read-only method to return a list or array ref of the field names. Returns undef
842 or an empty list if the table has no fields set. Useful if you want to
843 avoid the overload magic of the Field objects returned by the get_fields method.
845 my @names = $constraint->field_names;
856 return wantarray ? @fields : \@fields;
859 $self->error('No fields');
860 return wantarray ? () : undef;
870 Determines if this table is the same as another
872 my $isIdentical = $table1->equals( $table2 );
878 my $case_insensitive = shift;
880 return 0 unless $self->SUPER::equals($other);
881 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
882 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
883 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
886 # Go through our fields
888 foreach my $field ( $self->get_fields ) {
889 my $otherField = $other->get_field($field->name, $case_insensitive);
890 return 0 unless $field->equals($otherField, $case_insensitive);
891 $checkedFields{$field->name} = 1;
893 # Go through the other table's fields
894 foreach my $otherField ( $other->get_fields ) {
895 next if $checkedFields{$otherField->name};
900 # Go through our constraints
901 my %checkedConstraints;
903 foreach my $constraint ( $self->get_constraints ) {
904 foreach my $otherConstraint ( $other->get_constraints ) {
905 if ( $constraint->equals($otherConstraint, $case_insensitive) ) {
906 $checkedConstraints{$otherConstraint} = 1;
912 # Go through the other table's constraints
914 foreach my $otherConstraint ( $other->get_constraints ) {
915 next if $checkedFields{$otherConstraint};
916 foreach my $constraint ( $self->get_constraints ) {
917 if ( $otherConstraint->equals($constraint, $case_insensitive) ) {
925 # Go through our indices
928 foreach my $index ( $self->get_indices ) {
929 foreach my $otherIndex ( $other->get_indices ) {
930 if ( $index->equals($otherIndex, $case_insensitive) ) {
931 $checkedIndices{$otherIndex} = 1;
937 # Go through the other table's indices
939 foreach my $otherIndex ( $other->get_indices ) {
940 next if $checkedIndices{$otherIndex};
941 foreach my $index ( $self->get_indices ) {
942 if ( $otherIndex->equals($index, $case_insensitive) ) {
952 =head1 LOOKUP METHODS
954 The following are a set of shortcut methods for getting commonly used lists of
955 fields and constraints. They all return lists or array refs of Field or
962 The primary key fields.
966 All foreign key fields.
970 All the fields except the primary key.
978 All fields with unique constraints.
980 =item unique_constraints
982 All this tables unique constraints.
984 =item fkey_constraints
986 All this tables foreign key constraints. (See primary_key method to get the
987 primary key constraint)
995 my @fields = grep { $_->is_primary_key } $me->get_fields;
996 return wantarray ? @fields : \@fields;
1002 push @fields, $_->fields foreach $me->fkey_constraints;
1003 return wantarray ? @fields : \@fields;
1006 sub nonpkey_fields {
1008 my @fields = grep { !$_->is_primary_key } $me->get_fields;
1009 return wantarray ? @fields : \@fields;
1015 grep { !$_->is_foreign_key and !$_->is_primary_key } $me->get_fields;
1016 return wantarray ? @fields : \@fields;
1022 push @fields, $_->fields foreach $me->unique_constraints;
1023 return wantarray ? @fields : \@fields;
1026 sub unique_constraints {
1028 my @cons = grep { $_->type eq UNIQUE } $me->get_constraints;
1029 return wantarray ? @cons : \@cons;
1032 sub fkey_constraints {
1034 my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints;
1035 return wantarray ? @cons : \@cons;
1040 undef $self->{'schema'}; # destroy cyclical reference
1041 undef $_ for @{ $self->{'constraints'} };
1042 undef $_ for @{ $self->{'indices'} };
1043 undef $_ for values %{ $self->{'fields'} };
1046 # Must come after all 'has' declarations
1047 around new => \&ex2err;
1055 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
1056 Allen Day E<lt>allenday@ucla.eduE<gt>.