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::Role::Error
35 SQL::Translator::Role::BuildArgs
36 SQL::Translator::Schema::Role::Extra
37 SQL::Translator::Schema::Role::Compare
40 our $VERSION = '1.59';
42 # Stringify to our name, being careful not to pass any args through so we don't
43 # accidentally set it to undef. We also have to tweak bool so the object is
44 # still true when it doesn't have a name (which shouldn't happen!).
46 '""' => sub { shift->name },
47 'bool' => sub { $_[0]->name || $_[0] },
57 my $table = SQL::Translator::Schema::Table->new(
64 Add a constraint to the table. Returns the newly created
65 C<SQL::Translator::Schema::Constraint> object.
67 my $c1 = $table->add_constraint(
70 fields => [ 'foo_id' ],
73 my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
74 $c2 = $table->add_constraint( $constraint );
81 default => sub { +[] },
88 my $constraint_class = 'SQL::Translator::Schema::Constraint';
91 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
93 $constraint->table( $self );
97 $args{'table'} = $self;
98 $constraint = $constraint_class->new( \%args ) or
99 return $self->error( $constraint_class->error );
103 # If we're trying to add a PK when one is already defined,
104 # then just add the fields to the existing definition.
107 my $pk = $self->primary_key;
108 if ( $pk && $constraint->type eq PRIMARY_KEY ) {
109 $self->primary_key( $constraint->fields );
110 $pk->name($constraint->name) if $constraint->name;
111 my %extra = $constraint->extra;
112 $pk->extra(%extra) if keys %extra;
116 elsif ( $constraint->type eq PRIMARY_KEY ) {
117 for my $fname ( $constraint->fields ) {
118 if ( my $f = $self->get_field( $fname ) ) {
119 $f->is_primary_key( 1 );
124 # See if another constraint of the same type
125 # covers the same fields. -- This doesn't work! ky
127 # elsif ( $constraint->type ne CHECK_C ) {
128 # my @field_names = $constraint->fields;
130 # grep { $_->type eq $constraint->type }
131 # $self->get_constraints
133 # my %fields = map { $_, 1 } $c->fields;
134 # for my $field_name ( @field_names ) {
135 # if ( $fields{ $field_name } ) {
146 push @{ $self->_constraints }, $constraint;
152 =head2 drop_constraint
154 Remove a constraint from the table. Returns the constraint object if the index
155 was found and removed, an error otherwise. The single parameter can be either
156 an index name or an C<SQL::Translator::Schema::Constraint> object.
158 $table->drop_constraint('myconstraint');
162 sub drop_constraint {
164 my $constraint_class = 'SQL::Translator::Schema::Constraint';
167 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
168 $constraint_name = shift->name;
171 $constraint_name = shift;
174 if ( ! ($self->_has_constraints && grep { $_->name eq $constraint_name } @ { $self->_constraints }) ) {
175 return $self->error(qq[Can't drop constraint: "$constraint_name" doesn't exist]);
178 my @cs = @{ $self->_constraints };
179 my ($constraint_id) = grep { $cs[$_]->name eq $constraint_name } (0..$#cs);
180 my $constraint = splice(@{$self->_constraints}, $constraint_id, 1);
187 Add an index to the table. Returns the newly created
188 C<SQL::Translator::Schema::Index> object.
190 my $i1 = $table->add_index(
192 fields => [ 'name' ],
196 my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
197 $i2 = $table->add_index( $index );
204 default => sub { [] },
211 my $index_class = 'SQL::Translator::Schema::Index';
214 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
216 $index->table( $self );
220 $args{'table'} = $self;
221 $index = $index_class->new( \%args ) or return
222 $self->error( $index_class->error );
224 foreach my $ex_index ($self->get_indices) {
225 return if ($ex_index->equals($index));
227 push @{ $self->_indices }, $index;
233 Remove an index from the table. Returns the index object if the index was
234 found and removed, an error otherwise. The single parameter can be either
235 an index name of an C<SQL::Translator::Schema::Index> object.
237 $table->drop_index('myindex');
243 my $index_class = 'SQL::Translator::Schema::Index';
246 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
247 $index_name = shift->name;
253 if ( ! ($self->_has_indices && grep { $_->name eq $index_name } @{ $self->_indices }) ) {
254 return $self->error(qq[Can't drop index: "$index_name" doesn't exist]);
257 my @is = @{ $self->_indices };
258 my ($index_id) = grep { $is[$_]->name eq $index_name } (0..$#is);
259 my $index = splice(@{$self->_indices}, $index_id, 1);
266 Add an field to the table. Returns the newly created
267 C<SQL::Translator::Schema::Field> object. The "name" parameter is
268 required. If you try to create a field with the same name as an
269 existing field, you will get an error and the field will not be created.
271 my $f1 = $table->add_field(
273 data_type => 'integer',
277 my $f2 = SQL::Translator::Schema::Field->new(
281 $f2 = $table->add_field( $field2 ) or die $table->error;
288 default => sub { +{} },
295 my $field_class = 'SQL::Translator::Schema::Field';
298 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
300 $field->table( $self );
304 $args{'table'} = $self;
305 $field = $field_class->new( \%args ) or return
306 $self->error( $field_class->error );
309 my $existing_order = { map { $_->order => $_->name } $self->get_fields };
311 # supplied order, possible unordered assembly
312 if ( $field->order ) {
313 if($existing_order->{$field->order}) {
315 "Requested order '%d' for column '%s' conflicts with already existing column '%s'",
318 $existing_order->{$field->order},
323 my $last_field_no = max(keys %$existing_order) || 0;
324 if ( $last_field_no != scalar keys %$existing_order ) {
326 "Table '%s' field order incomplete - unable to auto-determine order for newly added field",
331 $field->order( $last_field_no + 1 );
334 # We know we have a name as the Field->new above errors if none given.
335 my $field_name = $field->name;
337 if ( $self->get_field($field_name) ) {
338 return $self->error(qq[Can't use field name "$field_name": field exists]);
341 $self->_fields->{ $field_name } = $field;
349 Remove a field from the table. Returns the field object if the field was
350 found and removed, an error otherwise. The single parameter can be either
351 a field name or an C<SQL::Translator::Schema::Field> object.
353 $table->drop_field('myfield');
359 my $field_class = 'SQL::Translator::Schema::Field';
362 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
363 $field_name = shift->name;
369 my $cascade = $args{'cascade'};
371 if ( ! ($self->_has_fields && exists $self->_fields->{ $field_name } ) ) {
372 return $self->error(qq[Can't drop field: "$field_name" doesn't exists]);
375 my $field = delete $self->_fields->{ $field_name };
378 # Remove this field from all indices using it
379 foreach my $i ($self->get_indices()) {
380 my @fs = $i->fields();
381 @fs = grep { $_ ne $field->name } @fs;
385 # Remove this field from all constraints using it
386 foreach my $c ($self->get_constraints()) {
387 my @cs = $c->fields();
388 @cs = grep { $_ ne $field->name } @cs;
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"
411 coerce => sub { ref($_[0]) eq 'ARRAY' ? $_[0] : [$_[0]] },
412 default => sub { [] },
415 around comments => sub {
418 my @comments = ref $_[0] ? @{ $_[0] } : @_;
420 for my $arg ( @comments ) {
421 $arg = $arg->[0] if ref $arg;
422 push @{ $self->$orig }, $arg if defined $arg && $arg;
425 @comments = @{$self->$orig};
426 return wantarray ? @comments
427 : @comments ? join( "\n", @comments )
431 =head2 get_constraints
433 Returns all the constraint objects as an array or array reference.
435 my @constraints = $table->get_constraints;
439 sub get_constraints {
442 if ( $self->_has_constraints ) {
444 ? @{ $self->_constraints } : $self->_constraints;
447 $self->error('No constraints');
448 return wantarray ? () : undef;
454 Returns all the index objects as an array or array reference.
456 my @indices = $table->get_indices;
463 if ( $self->_has_indices ) {
465 ? @{ $self->_indices }
469 $self->error('No indices');
470 return wantarray ? () : undef;
476 Returns a field by the name provided.
478 my $field = $table->get_field('foo');
484 my $field_name = shift or return $self->error('No field name');
485 my $case_insensitive = shift;
486 return $self->error(qq[Field "$field_name" does not exist])
487 unless $self->_has_fields;
488 if ( $case_insensitive ) {
489 $field_name = uc($field_name);
490 foreach my $field ( keys %{$self->_fields} ) {
491 return $self->_fields->{$field} if $field_name eq uc($field);
493 return $self->error(qq[Field "$field_name" does not exist]);
495 return $self->error( qq[Field "$field_name" does not exist] ) unless
496 exists $self->_fields->{ $field_name };
497 return $self->_fields->{ $field_name };
502 Returns all the field objects as an array or array reference.
504 my @fields = $table->get_fields;
512 sort { $a->[0] <=> $b->[0] }
513 map { [ $_->order, $_ ] }
514 values %{ $self->_has_fields ? $self->_fields : {} };
517 return wantarray ? @fields : \@fields;
520 $self->error('No fields');
521 return wantarray ? () : undef;
527 Determine whether the view is valid or not.
529 my $ok = $view->is_valid;
535 return $self->error('No name') unless $self->name;
536 return $self->error('No fields') unless $self->get_fields;
539 $self->get_fields, $self->get_indices, $self->get_constraints
541 return $object->error unless $object->is_valid;
547 =head2 is_trivial_link
549 True if table has no data (non-key) fields and only uses single key joins.
553 has is_trivial_link => ( is => 'lazy', init_arg => undef );
555 sub _build_is_trivial_link {
557 return 0 if $self->is_data;
561 foreach my $field ( $self->get_fields ) {
562 next unless $field->is_foreign_key;
563 $fk{$field->foreign_key_reference->reference_table}++;
566 foreach my $referenced (keys %fk){
567 if($fk{$referenced} > 1){
577 Returns true if the table has some non-key fields.
581 has is_data => ( is => 'lazy', init_arg => undef );
586 foreach my $field ( $self->get_fields ) {
587 if ( !$field->is_primary_key and !$field->is_foreign_key ) {
597 Determine whether the table can link two arg tables via many-to-many.
599 my $ok = $table->can_link($table1,$table2);
603 has _can_link => ( is => 'ro', init_arg => undef, default => sub { +{} } );
606 my ( $self, $table1, $table2 ) = @_;
608 return $self->_can_link->{ $table1->name }{ $table2->name }
609 if defined $self->_can_link->{ $table1->name }{ $table2->name };
611 if ( $self->is_data == 1 ) {
612 $self->_can_link->{ $table1->name }{ $table2->name } = [0];
613 $self->_can_link->{ $table2->name }{ $table1->name } = [0];
614 return $self->_can_link->{ $table1->name }{ $table2->name };
619 foreach my $field ( $self->get_fields ) {
620 if ( $field->is_foreign_key ) {
621 push @{ $fk{ $field->foreign_key_reference->reference_table } },
622 $field->foreign_key_reference;
626 if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
628 $self->_can_link->{ $table1->name }{ $table2->name } = [0];
629 $self->_can_link->{ $table2->name }{ $table1->name } = [0];
630 return $self->_can_link->{ $table1->name }{ $table2->name };
633 # trivial traversal, only one way to link the two tables
634 if ( scalar( @{ $fk{ $table1->name } } == 1 )
635 and scalar( @{ $fk{ $table2->name } } == 1 ) )
637 $self->_can_link->{ $table1->name }{ $table2->name } =
638 [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
639 $self->_can_link->{ $table1->name }{ $table2->name } =
640 [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
642 # non-trivial traversal. one way to link table2,
643 # many ways to link table1
645 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
646 and scalar( @{ $fk{ $table2->name } } == 1 ) )
648 $self->_can_link->{ $table1->name }{ $table2->name } =
649 [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
650 $self->_can_link->{ $table2->name }{ $table1->name } =
651 [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
653 # non-trivial traversal. one way to link table1,
654 # many ways to link table2
656 elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
657 and scalar( @{ $fk{ $table2->name } } > 1 ) )
659 $self->_can_link->{ $table1->name }{ $table2->name } =
660 [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
661 $self->_can_link->{ $table2->name }{ $table1->name } =
662 [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
664 # non-trivial traversal. many ways to link table1 and table2
666 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
667 and scalar( @{ $fk{ $table2->name } } > 1 ) )
669 $self->_can_link->{ $table1->name }{ $table2->name } =
670 [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
671 $self->_can_link->{ $table2->name }{ $table1->name } =
672 [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
674 # one of the tables didn't export a key
675 # to this table, no linking possible
678 $self->_can_link->{ $table1->name }{ $table2->name } = [0];
679 $self->_can_link->{ $table2->name }{ $table1->name } = [0];
682 return $self->_can_link->{ $table1->name }{ $table2->name };
687 Get or set the table's name.
689 Errors ("No table name") if you try to set a blank name.
691 If provided an argument, checks the schema object for a table of
692 that name and disallows the change if one exists (setting the error to
693 "Can't use table name "%s": table exists").
695 my $table_name = $table->name('foo');
701 isa => sub { throw("No table name") unless $_[0] },
708 if ( my ($arg) = @_ ) {
709 if ( my $schema = $self->schema ) {
710 return $self->error( qq[Can't use table name "$arg": table exists] )
711 if $schema->get_table( $arg );
715 return ex2err($orig, $self, @_);
720 Get or set the table's schema object.
722 my $schema = $table->schema;
726 has schema => ( is => 'rw', isa => schema_obj('Schema'), weak_ref => 1 );
728 around schema => \&ex2err;
736 Gets or sets the table's primary key(s). Takes one or more field
737 names (as a string, list or array[ref]) as an argument. If the field
738 names are present, it will create a new PK if none exists, or it will
739 add to the fields of an existing PK (and will unique the field names).
740 Returns the C<SQL::Translator::Schema::Constraint> object representing
745 $table->primary_key('id');
746 $table->primary_key(['name']);
747 $table->primary_key('id','name']);
748 $table->primary_key(['id','name']);
749 $table->primary_key('id,name');
750 $table->primary_key(qw[ id name ]);
752 my $pk = $table->primary_key;
757 my $fields = parse_list_arg( @_ );
761 for my $f ( @$fields ) {
762 return $self->error(qq[Invalid field "$f"]) unless
763 $self->get_field($f);
767 for my $c ( $self->get_constraints ) {
768 if ( $c->type eq PRIMARY_KEY ) {
770 $c->fields( @{ $c->fields }, @$fields );
776 $constraint = $self->add_constraint(
787 for my $c ( $self->get_constraints ) {
788 return $c if $c->type eq PRIMARY_KEY;
797 Get or set the table's options (e.g., table types for MySQL). Returns
798 an array or array reference.
800 my @options = $table->options;
806 default => sub { [] },
807 coerce => \&parse_list_arg,
810 around options => sub {
813 my $options = parse_list_arg( @_ );
815 push @{ $self->$orig }, @$options;
817 return wantarray ? @{ $self->$orig } : $self->$orig;
822 Get or set the table's order.
824 my $order = $table->order(3);
828 has order => ( is => 'rw', default => sub { 0 } );
830 around order => sub {
831 my ( $orig, $self, $arg ) = @_;
833 if ( defined $arg && $arg =~ /^\d+$/ ) {
834 return $self->$orig($arg);
842 Read-only method to return a list or array ref of the field names. Returns undef
843 or an empty list if the table has no fields set. Useful if you want to
844 avoid the overload magic of the Field objects returned by the get_fields method.
846 my @names = $constraint->field_names;
857 return wantarray ? @fields : \@fields;
860 $self->error('No fields');
861 return wantarray ? () : undef;
871 Determines if this table is the same as another
873 my $isIdentical = $table1->equals( $table2 );
879 my $case_insensitive = shift;
881 return 0 unless $self->SUPER::equals($other);
882 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
883 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
884 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
887 # Go through our fields
889 foreach my $field ( $self->get_fields ) {
890 my $otherField = $other->get_field($field->name, $case_insensitive);
891 return 0 unless $field->equals($otherField, $case_insensitive);
892 $checkedFields{$field->name} = 1;
894 # Go through the other table's fields
895 foreach my $otherField ( $other->get_fields ) {
896 next if $checkedFields{$otherField->name};
901 # Go through our constraints
902 my %checkedConstraints;
904 foreach my $constraint ( $self->get_constraints ) {
905 foreach my $otherConstraint ( $other->get_constraints ) {
906 if ( $constraint->equals($otherConstraint, $case_insensitive) ) {
907 $checkedConstraints{$otherConstraint} = 1;
913 # Go through the other table's constraints
915 foreach my $otherConstraint ( $other->get_constraints ) {
916 next if $checkedFields{$otherConstraint};
917 foreach my $constraint ( $self->get_constraints ) {
918 if ( $otherConstraint->equals($constraint, $case_insensitive) ) {
926 # Go through our indices
929 foreach my $index ( $self->get_indices ) {
930 foreach my $otherIndex ( $other->get_indices ) {
931 if ( $index->equals($otherIndex, $case_insensitive) ) {
932 $checkedIndices{$otherIndex} = 1;
938 # Go through the other table's indices
940 foreach my $otherIndex ( $other->get_indices ) {
941 next if $checkedIndices{$otherIndex};
942 foreach my $index ( $self->get_indices ) {
943 if ( $otherIndex->equals($index, $case_insensitive) ) {
953 =head1 LOOKUP METHODS
955 The following are a set of shortcut methods for getting commonly used lists of
956 fields and constraints. They all return lists or array refs of Field or
963 The primary key fields.
967 All foreign key fields.
971 All the fields except the primary key.
979 All fields with unique constraints.
981 =item unique_constraints
983 All this tables unique constraints.
985 =item fkey_constraints
987 All this tables foreign key constraints. (See primary_key method to get the
988 primary key constraint)
996 my @fields = grep { $_->is_primary_key } $me->get_fields;
997 return wantarray ? @fields : \@fields;
1003 push @fields, $_->fields foreach $me->fkey_constraints;
1004 return wantarray ? @fields : \@fields;
1007 sub nonpkey_fields {
1009 my @fields = grep { !$_->is_primary_key } $me->get_fields;
1010 return wantarray ? @fields : \@fields;
1016 grep { !$_->is_foreign_key and !$_->is_primary_key } $me->get_fields;
1017 return wantarray ? @fields : \@fields;
1023 push @fields, $_->fields foreach $me->unique_constraints;
1024 return wantarray ? @fields : \@fields;
1027 sub unique_constraints {
1029 my @cons = grep { $_->type eq UNIQUE } $me->get_constraints;
1030 return wantarray ? @cons : \@cons;
1033 sub fkey_constraints {
1035 my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints;
1036 return wantarray ? @cons : \@cons;
1039 # Must come after all 'has' declarations
1040 around new => \&ex2err;
1048 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
1049 Allen Day E<lt>allenday@ucla.eduE<gt>.