1 package SQL::Translator::Schema::Table;
3 # ----------------------------------------------------------------------
4 # $Id: Table.pm,v 1.26 2004-03-29 12:25:54 grommit 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.
44 use SQL::Translator::Utils 'parse_list_arg';
45 use SQL::Translator::Schema::Constants;
46 use SQL::Translator::Schema::Constraint;
47 use SQL::Translator::Schema::Field;
48 use SQL::Translator::Schema::Index;
51 use base 'Class::Base';
52 use vars qw( $VERSION $FIELD_ORDER );
54 $VERSION = sprintf "%d.%02d", q$Revision: 1.26 $ =~ /(\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 # ----------------------------------------------------------------------
75 my $table = SQL::Translator::Schema::Table->new(
82 my ( $self, $config ) = @_;
84 for my $arg ( qw[ schema name comments ] ) {
85 next unless defined $config->{ $arg };
86 defined $self->$arg( $config->{ $arg } ) or return;
92 # ----------------------------------------------------------------------
99 Add a constraint to the table. Returns the newly created
100 C<SQL::Translator::Schema::Constraint> object.
102 my $c1 = $table->add_constraint(
105 fields => [ 'foo_id' ],
108 my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
109 $c2 = $table->add_constraint( $constraint );
114 my $constraint_class = 'SQL::Translator::Schema::Constraint';
117 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
119 $constraint->table( $self );
123 $args{'table'} = $self;
124 $constraint = $constraint_class->new( \%args ) or
125 return $self->error( $constraint_class->error );
129 # If we're trying to add a PK when one is already defined,
130 # then just add the fields to the existing definition.
133 my $pk = $self->primary_key;
134 if ( $pk && $constraint->type eq PRIMARY_KEY ) {
135 $self->primary_key( $constraint->fields );
139 elsif ( $constraint->type eq PRIMARY_KEY ) {
140 for my $fname ( $constraint->fields ) {
141 if ( my $f = $self->get_field( $fname ) ) {
142 $f->is_primary_key( 1 );
147 # See if another constraint of the same type
148 # covers the same fields. -- This doesn't work! ky
150 # elsif ( $constraint->type ne CHECK_C ) {
151 # my @field_names = $constraint->fields;
153 # grep { $_->type eq $constraint->type }
154 # $self->get_constraints
156 # my %fields = map { $_, 1 } $c->fields;
157 # for my $field_name ( @field_names ) {
158 # if ( $fields{ $field_name } ) {
169 push @{ $self->{'constraints'} }, $constraint;
175 # ----------------------------------------------------------------------
182 Add an index to the table. Returns the newly created
183 C<SQL::Translator::Schema::Index> object.
185 my $i1 = $table->add_index(
187 fields => [ 'name' ],
191 my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
192 $i2 = $table->add_index( $index );
197 my $index_class = 'SQL::Translator::Schema::Index';
200 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
202 $index->table( $self );
206 $args{'table'} = $self;
207 $index = $index_class->new( \%args ) or return
208 $self->error( $index_class->error );
211 push @{ $self->{'indices'} }, $index;
215 # ----------------------------------------------------------------------
222 Add an field to the table. Returns the newly created
223 C<SQL::Translator::Schema::Field> object. The "name" parameter is
224 required. If you try to create a field with the same name as an
225 existing field, you will get an error and the field will not be created.
227 my $f1 = $table->add_field(
229 data_type => 'integer',
233 my $f2 = SQL::Translator::Schema::Field->new(
237 $f2 = $table->add_field( $field2 ) or die $table->error;
242 my $field_class = 'SQL::Translator::Schema::Field';
245 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
247 $field->table( $self );
251 $args{'table'} = $self;
252 $field = $field_class->new( \%args ) or return
253 $self->error( $field_class->error );
256 $field->order( ++$FIELD_ORDER );
257 # We know we have a name as the Field->new above errors if none given.
258 my $field_name = $field->name;
260 if ( exists $self->{'fields'}{ $field_name } ) {
261 return $self->error(qq[Can't create field: "$field_name" exists]);
264 $self->{'fields'}{ $field_name } = $field;
270 # ----------------------------------------------------------------------
277 Get or set the comments on a table. May be called several times to
278 set and it will accumulate the comments. Called in an array context,
279 returns each comment individually; called in a scalar context, returns
280 all the comments joined on newlines.
282 $table->comments('foo');
283 $table->comments('bar');
284 print join( ', ', $table->comments ); # prints "foo, bar"
289 my @comments = ref $_[0] ? @{ $_[0] } : @_;
291 for my $arg ( @comments ) {
292 $arg = $arg->[0] if ref $arg;
293 push @{ $self->{'comments'} }, $arg if defined $arg && $arg;
296 if ( @{ $self->{'comments'} || [] } ) {
298 ? @{ $self->{'comments'} }
299 : join( "\n", @{ $self->{'comments'} } )
303 return wantarray ? () : undef;
307 # ----------------------------------------------------------------------
308 sub get_constraints {
312 =head2 get_constraints
314 Returns all the constraint objects as an array or array reference.
316 my @constraints = $table->get_constraints;
322 if ( ref $self->{'constraints'} ) {
324 ? @{ $self->{'constraints'} } : $self->{'constraints'};
327 $self->error('No constraints');
328 return wantarray ? () : undef;
332 # ----------------------------------------------------------------------
339 Returns all the index objects as an array or array reference.
341 my @indices = $table->get_indices;
347 if ( ref $self->{'indices'} ) {
349 ? @{ $self->{'indices'} }
350 : $self->{'indices'};
353 $self->error('No indices');
354 return wantarray ? () : undef;
358 # ----------------------------------------------------------------------
365 Returns a field by the name provided.
367 my $field = $table->get_field('foo');
372 my $field_name = shift or return $self->error('No field name');
373 return $self->error( qq[Field "$field_name" does not exist] ) unless
374 exists $self->{'fields'}{ $field_name };
375 return $self->{'fields'}{ $field_name };
378 # ----------------------------------------------------------------------
385 Returns all the field objects as an array or array reference.
387 my @fields = $table->get_fields;
394 sort { $a->[0] <=> $b->[0] }
395 map { [ $_->order, $_ ] }
396 values %{ $self->{'fields'} || {} };
399 return wantarray ? @fields : \@fields;
402 $self->error('No fields');
403 return wantarray ? () : undef;
407 # ----------------------------------------------------------------------
414 Determine whether the view is valid or not.
416 my $ok = $view->is_valid;
421 return $self->error('No name') unless $self->name;
422 return $self->error('No fields') unless $self->get_fields;
425 $self->get_fields, $self->get_indices, $self->get_constraints
427 return $object->error unless $object->is_valid;
433 # ----------------------------------------------------------------------
434 sub is_trivial_link {
438 =head2 is_trivial_link
440 True if table has no data (non-key) fields and only uses single key joins.
445 return 0 if $self->is_data;
446 return $self->{'is_trivial_link'} if defined $self->{'is_trivial_link'};
448 $self->{'is_trivial_link'} = 1;
452 foreach my $field ( $self->get_fields ) {
453 next unless $field->is_foreign_key;
454 $fk{$field->foreign_key_reference->reference_table}++;
457 foreach my $referenced (keys %fk){
458 if($fk{$referenced} > 1){
459 $self->{'is_trivial_link'} = 0;
464 return $self->{'is_trivial_link'};
474 Returns true if the table has some non-key fields.
479 return $self->{'is_data'} if defined $self->{'is_data'};
481 $self->{'is_data'} = 0;
483 foreach my $field ( $self->get_fields ) {
484 if ( !$field->is_primary_key and !$field->is_foreign_key ) {
485 $self->{'is_data'} = 1;
486 return $self->{'is_data'};
490 return $self->{'is_data'};
493 # ----------------------------------------------------------------------
500 Determine whether the table can link two arg tables via many-to-many.
502 my $ok = $table->can_link($table1,$table2);
506 my ( $self, $table1, $table2 ) = @_;
508 return $self->{'can_link'}{ $table1->name }{ $table2->name }
509 if defined $self->{'can_link'}{ $table1->name }{ $table2->name };
511 if ( $self->is_data == 1 ) {
512 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
513 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
514 return $self->{'can_link'}{ $table1->name }{ $table2->name };
519 foreach my $field ( $self->get_fields ) {
520 if ( $field->is_foreign_key ) {
521 push @{ $fk{ $field->foreign_key_reference->reference_table } },
522 $field->foreign_key_reference;
526 if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
528 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
529 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
530 return $self->{'can_link'}{ $table1->name }{ $table2->name };
533 # trivial traversal, only one way to link the two tables
534 if ( scalar( @{ $fk{ $table1->name } } == 1 )
535 and scalar( @{ $fk{ $table2->name } } == 1 ) )
537 $self->{'can_link'}{ $table1->name }{ $table2->name } =
538 [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
539 $self->{'can_link'}{ $table1->name }{ $table2->name } =
540 [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
542 # non-trivial traversal. one way to link table2,
543 # many ways to link table1
545 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
546 and scalar( @{ $fk{ $table2->name } } == 1 ) )
548 $self->{'can_link'}{ $table1->name }{ $table2->name } =
549 [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
550 $self->{'can_link'}{ $table2->name }{ $table1->name } =
551 [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
553 # non-trivial traversal. one way to link table1,
554 # many ways to link table2
556 elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
557 and scalar( @{ $fk{ $table2->name } } > 1 ) )
559 $self->{'can_link'}{ $table1->name }{ $table2->name } =
560 [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
561 $self->{'can_link'}{ $table2->name }{ $table1->name } =
562 [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
564 # non-trivial traversal. many ways to link table1 and table2
566 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
567 and scalar( @{ $fk{ $table2->name } } > 1 ) )
569 $self->{'can_link'}{ $table1->name }{ $table2->name } =
570 [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
571 $self->{'can_link'}{ $table2->name }{ $table1->name } =
572 [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
574 # one of the tables didn't export a key
575 # to this table, no linking possible
578 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
579 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
582 return $self->{'can_link'}{ $table1->name }{ $table2->name };
585 # ----------------------------------------------------------------------
592 Get or set the table's name.
594 Errors ("No table name") if you try to set a blank name.
596 If provided an argument, checks the schema object for a table of
597 that name and disallows the change if one exists (setting the error to
598 "Can't use table name "%s": table exists").
600 my $table_name = $table->name('foo');
607 my $arg = shift || return $self->error( "No table name" );
608 if ( my $schema = $self->schema ) {
609 return $self->error( qq[Can't use table name "$arg": table exists] )
610 if $schema->get_table( $arg );
612 $self->{'name'} = $arg;
615 return $self->{'name'} || '';
618 # ----------------------------------------------------------------------
625 Get or set the table's schema object.
627 my $schema = $table->schema;
632 if ( my $arg = shift ) {
633 return $self->error('Not a schema object') unless
634 UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
635 $self->{'schema'} = $arg;
638 return $self->{'schema'};
641 # ----------------------------------------------------------------------
648 Gets or sets the table's primary key(s). Takes one or more field
649 names (as a string, list or array[ref]) as an argument. If the field
650 names are present, it will create a new PK if none exists, or it will
651 add to the fields of an existing PK (and will unique the field names).
652 Returns the C<SQL::Translator::Schema::Constraint> object representing
657 $table->primary_key('id');
658 $table->primary_key(['name']);
659 $table->primary_key('id','name']);
660 $table->primary_key(['id','name']);
661 $table->primary_key('id,name');
662 $table->primary_key(qw[ id name ]);
664 my $pk = $table->primary_key;
669 my $fields = parse_list_arg( @_ );
673 for my $f ( @$fields ) {
674 return $self->error(qq[Invalid field "$f"]) unless
675 $self->get_field($f);
679 for my $c ( $self->get_constraints ) {
680 if ( $c->type eq PRIMARY_KEY ) {
682 $c->fields( @{ $c->fields }, @$fields );
688 $constraint = $self->add_constraint(
699 for my $c ( $self->get_constraints ) {
700 return $c if $c->type eq PRIMARY_KEY;
707 # ----------------------------------------------------------------------
714 Get or set the table's options (e.g., table types for MySQL). Returns
715 an array or array reference.
717 my @options = $table->options;
722 my $options = parse_list_arg( @_ );
724 push @{ $self->{'options'} }, @$options;
726 if ( ref $self->{'options'} ) {
727 return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
730 return wantarray ? () : [];
734 # ----------------------------------------------------------------------
741 Get or set the table's order.
743 my $order = $table->order(3);
747 my ( $self, $arg ) = @_;
749 if ( defined $arg && $arg =~ /^\d+$/ ) {
750 $self->{'order'} = $arg;
753 return $self->{'order'} || 0;
756 # ----------------------------------------------------------------------
761 Read-only method to return a list or array ref of the field names. Returns undef
762 or an empty list if the table has no fields set. Usefull if you want to
763 avoid the overload magic of the Field objects returned by the get_fields method.
765 my @names = $constraint->field_names;
772 sort { $a->order <=> $b->order }
773 values %{ $self->{'fields'} || {} };
776 return wantarray ? @fields : \@fields;
779 $self->error('No fields');
780 return wantarray ? () : undef;
784 # ----------------------------------------------------------------------
786 =head1 LOOKUP METHODS
788 The following are a set of shortcut methods for getting commonly used lists of
789 fields and constraints. They all return lists or array refs of Field or
796 The primary key fields.
800 All foreign key fields.
804 All the fields except the primary key.
812 All fields with unique constraints.
814 =item unique_constraints
816 All this tables unique constraints.
818 =item fkey_constraints
820 All this tables foreign key constraints. (See primary_key method to get the
821 primary key constraint)
829 my @fields = grep { $_->is_primary_key } $me->get_fields;
830 return wantarray ? @fields : \@fields;
833 # ----------------------------------------------------------------------
837 push @fields, $_->fields foreach $me->fkey_constraints;
838 return wantarray ? @fields : \@fields;
841 # ----------------------------------------------------------------------
844 my @fields = grep { !$_->is_primary_key } $me->get_fields;
845 return wantarray ? @fields : \@fields;
848 # ----------------------------------------------------------------------
852 grep { !$_->is_foreign_key and !$_->is_primary_key } $me->get_fields;
853 return wantarray ? @fields : \@fields;
856 # ----------------------------------------------------------------------
860 push @fields, $_->fields foreach $me->unique_constraints;
861 return wantarray ? @fields : \@fields;
864 # ----------------------------------------------------------------------
865 sub unique_constraints {
867 my @cons = grep { $_->type eq UNIQUE } $me->get_constraints;
868 return wantarray ? @cons : \@cons;
871 # ----------------------------------------------------------------------
872 sub fkey_constraints {
874 my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints;
875 return wantarray ? @cons : \@cons;
878 # ----------------------------------------------------------------------
881 undef $self->{'schema'}; # destroy cyclical reference
882 undef $_ for @{ $self->{'constraints'} };
883 undef $_ for @{ $self->{'indices'} };
884 undef $_ for values %{ $self->{'fields'} };
889 # ----------------------------------------------------------------------
895 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
896 Allen Day E<lt>allenday@ucla.eduE<gt>.