1 package SQL::Translator::Schema::Table;
3 # ----------------------------------------------------------------------
4 # $Id: Table.pm,v 1.29 2004-11-05 15:03:10 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.
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.29 $ =~ /(\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 # ----------------------------------------------------------------------
176 Add an index to the table. Returns the newly created
177 C<SQL::Translator::Schema::Index> object.
179 my $i1 = $table->add_index(
181 fields => [ 'name' ],
185 my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
186 $i2 = $table->add_index( $index );
191 my $index_class = 'SQL::Translator::Schema::Index';
194 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
196 $index->table( $self );
200 $args{'table'} = $self;
201 $index = $index_class->new( \%args ) or return
202 $self->error( $index_class->error );
205 push @{ $self->{'indices'} }, $index;
209 # ----------------------------------------------------------------------
216 Add an field to the table. Returns the newly created
217 C<SQL::Translator::Schema::Field> object. The "name" parameter is
218 required. If you try to create a field with the same name as an
219 existing field, you will get an error and the field will not be created.
221 my $f1 = $table->add_field(
223 data_type => 'integer',
227 my $f2 = SQL::Translator::Schema::Field->new(
231 $f2 = $table->add_field( $field2 ) or die $table->error;
236 my $field_class = 'SQL::Translator::Schema::Field';
239 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
241 $field->table( $self );
245 $args{'table'} = $self;
246 $field = $field_class->new( \%args ) or return
247 $self->error( $field_class->error );
250 $field->order( ++$FIELD_ORDER );
251 # We know we have a name as the Field->new above errors if none given.
252 my $field_name = $field->name;
254 if ( exists $self->{'fields'}{ $field_name } ) {
255 return $self->error(qq[Can't create field: "$field_name" exists]);
258 $self->{'fields'}{ $field_name } = $field;
264 # ----------------------------------------------------------------------
271 Get or set the comments on a table. May be called several times to
272 set and it will accumulate the comments. Called in an array context,
273 returns each comment individually; called in a scalar context, returns
274 all the comments joined on newlines.
276 $table->comments('foo');
277 $table->comments('bar');
278 print join( ', ', $table->comments ); # prints "foo, bar"
283 my @comments = ref $_[0] ? @{ $_[0] } : @_;
285 for my $arg ( @comments ) {
286 $arg = $arg->[0] if ref $arg;
287 push @{ $self->{'comments'} }, $arg if defined $arg && $arg;
290 if ( @{ $self->{'comments'} || [] } ) {
292 ? @{ $self->{'comments'} }
293 : join( "\n", @{ $self->{'comments'} } )
297 return wantarray ? () : undef;
301 # ----------------------------------------------------------------------
302 sub get_constraints {
306 =head2 get_constraints
308 Returns all the constraint objects as an array or array reference.
310 my @constraints = $table->get_constraints;
316 if ( ref $self->{'constraints'} ) {
318 ? @{ $self->{'constraints'} } : $self->{'constraints'};
321 $self->error('No constraints');
322 return wantarray ? () : undef;
326 # ----------------------------------------------------------------------
333 Returns all the index objects as an array or array reference.
335 my @indices = $table->get_indices;
341 if ( ref $self->{'indices'} ) {
343 ? @{ $self->{'indices'} }
344 : $self->{'indices'};
347 $self->error('No indices');
348 return wantarray ? () : undef;
352 # ----------------------------------------------------------------------
359 Returns a field by the name provided.
361 my $field = $table->get_field('foo');
366 my $field_name = shift or return $self->error('No field name');
367 return $self->error( qq[Field "$field_name" does not exist] ) unless
368 exists $self->{'fields'}{ $field_name };
369 return $self->{'fields'}{ $field_name };
372 # ----------------------------------------------------------------------
379 Returns all the field objects as an array or array reference.
381 my @fields = $table->get_fields;
388 sort { $a->[0] <=> $b->[0] }
389 map { [ $_->order, $_ ] }
390 values %{ $self->{'fields'} || {} };
393 return wantarray ? @fields : \@fields;
396 $self->error('No fields');
397 return wantarray ? () : undef;
401 # ----------------------------------------------------------------------
408 Determine whether the view is valid or not.
410 my $ok = $view->is_valid;
415 return $self->error('No name') unless $self->name;
416 return $self->error('No fields') unless $self->get_fields;
419 $self->get_fields, $self->get_indices, $self->get_constraints
421 return $object->error unless $object->is_valid;
427 # ----------------------------------------------------------------------
428 sub is_trivial_link {
432 =head2 is_trivial_link
434 True if table has no data (non-key) fields and only uses single key joins.
439 return 0 if $self->is_data;
440 return $self->{'is_trivial_link'} if defined $self->{'is_trivial_link'};
442 $self->{'is_trivial_link'} = 1;
446 foreach my $field ( $self->get_fields ) {
447 next unless $field->is_foreign_key;
448 $fk{$field->foreign_key_reference->reference_table}++;
451 foreach my $referenced (keys %fk){
452 if($fk{$referenced} > 1){
453 $self->{'is_trivial_link'} = 0;
458 return $self->{'is_trivial_link'};
468 Returns true if the table has some non-key fields.
473 return $self->{'is_data'} if defined $self->{'is_data'};
475 $self->{'is_data'} = 0;
477 foreach my $field ( $self->get_fields ) {
478 if ( !$field->is_primary_key and !$field->is_foreign_key ) {
479 $self->{'is_data'} = 1;
480 return $self->{'is_data'};
484 return $self->{'is_data'};
487 # ----------------------------------------------------------------------
494 Determine whether the table can link two arg tables via many-to-many.
496 my $ok = $table->can_link($table1,$table2);
500 my ( $self, $table1, $table2 ) = @_;
502 return $self->{'can_link'}{ $table1->name }{ $table2->name }
503 if defined $self->{'can_link'}{ $table1->name }{ $table2->name };
505 if ( $self->is_data == 1 ) {
506 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
507 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
508 return $self->{'can_link'}{ $table1->name }{ $table2->name };
513 foreach my $field ( $self->get_fields ) {
514 if ( $field->is_foreign_key ) {
515 push @{ $fk{ $field->foreign_key_reference->reference_table } },
516 $field->foreign_key_reference;
520 if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
522 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
523 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
524 return $self->{'can_link'}{ $table1->name }{ $table2->name };
527 # trivial traversal, only one way to link the two tables
528 if ( scalar( @{ $fk{ $table1->name } } == 1 )
529 and scalar( @{ $fk{ $table2->name } } == 1 ) )
531 $self->{'can_link'}{ $table1->name }{ $table2->name } =
532 [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
533 $self->{'can_link'}{ $table1->name }{ $table2->name } =
534 [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
536 # non-trivial traversal. one way to link table2,
537 # many ways to link table1
539 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
540 and scalar( @{ $fk{ $table2->name } } == 1 ) )
542 $self->{'can_link'}{ $table1->name }{ $table2->name } =
543 [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
544 $self->{'can_link'}{ $table2->name }{ $table1->name } =
545 [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
547 # non-trivial traversal. one way to link table1,
548 # many ways to link table2
550 elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
551 and scalar( @{ $fk{ $table2->name } } > 1 ) )
553 $self->{'can_link'}{ $table1->name }{ $table2->name } =
554 [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
555 $self->{'can_link'}{ $table2->name }{ $table1->name } =
556 [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
558 # non-trivial traversal. many ways to link table1 and table2
560 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
561 and scalar( @{ $fk{ $table2->name } } > 1 ) )
563 $self->{'can_link'}{ $table1->name }{ $table2->name } =
564 [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
565 $self->{'can_link'}{ $table2->name }{ $table1->name } =
566 [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
568 # one of the tables didn't export a key
569 # to this table, no linking possible
572 $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
573 $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
576 return $self->{'can_link'}{ $table1->name }{ $table2->name };
579 # ----------------------------------------------------------------------
586 Get or set the table's name.
588 Errors ("No table name") if you try to set a blank name.
590 If provided an argument, checks the schema object for a table of
591 that name and disallows the change if one exists (setting the error to
592 "Can't use table name "%s": table exists").
594 my $table_name = $table->name('foo');
601 my $arg = shift || return $self->error( "No table name" );
602 if ( my $schema = $self->schema ) {
603 return $self->error( qq[Can't use table name "$arg": table exists] )
604 if $schema->get_table( $arg );
606 $self->{'name'} = $arg;
609 return $self->{'name'} || '';
612 # ----------------------------------------------------------------------
619 Get or set the table's schema object.
621 my $schema = $table->schema;
626 if ( my $arg = shift ) {
627 return $self->error('Not a schema object') unless
628 UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
629 $self->{'schema'} = $arg;
632 return $self->{'schema'};
635 # ----------------------------------------------------------------------
642 Gets or sets the table's primary key(s). Takes one or more field
643 names (as a string, list or array[ref]) as an argument. If the field
644 names are present, it will create a new PK if none exists, or it will
645 add to the fields of an existing PK (and will unique the field names).
646 Returns the C<SQL::Translator::Schema::Constraint> object representing
651 $table->primary_key('id');
652 $table->primary_key(['name']);
653 $table->primary_key('id','name']);
654 $table->primary_key(['id','name']);
655 $table->primary_key('id,name');
656 $table->primary_key(qw[ id name ]);
658 my $pk = $table->primary_key;
663 my $fields = parse_list_arg( @_ );
667 for my $f ( @$fields ) {
668 return $self->error(qq[Invalid field "$f"]) unless
669 $self->get_field($f);
673 for my $c ( $self->get_constraints ) {
674 if ( $c->type eq PRIMARY_KEY ) {
676 $c->fields( @{ $c->fields }, @$fields );
682 $constraint = $self->add_constraint(
693 for my $c ( $self->get_constraints ) {
694 return $c if $c->type eq PRIMARY_KEY;
701 # ----------------------------------------------------------------------
708 Get or set the table's options (e.g., table types for MySQL). Returns
709 an array or array reference.
711 my @options = $table->options;
716 my $options = parse_list_arg( @_ );
718 push @{ $self->{'options'} }, @$options;
720 if ( ref $self->{'options'} ) {
721 return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
724 return wantarray ? () : [];
728 # ----------------------------------------------------------------------
735 Get or set the table's order.
737 my $order = $table->order(3);
741 my ( $self, $arg ) = @_;
743 if ( defined $arg && $arg =~ /^\d+$/ ) {
744 $self->{'order'} = $arg;
747 return $self->{'order'} || 0;
750 # ----------------------------------------------------------------------
755 Read-only method to return a list or array ref of the field names. Returns undef
756 or an empty list if the table has no fields set. Usefull if you want to
757 avoid the overload magic of the Field objects returned by the get_fields method.
759 my @names = $constraint->field_names;
766 sort { $a->order <=> $b->order }
767 values %{ $self->{'fields'} || {} };
770 return wantarray ? @fields : \@fields;
773 $self->error('No fields');
774 return wantarray ? () : undef;
778 # ----------------------------------------------------------------------
780 =head1 LOOKUP METHODS
782 The following are a set of shortcut methods for getting commonly used lists of
783 fields and constraints. They all return lists or array refs of Field or
790 The primary key fields.
794 All foreign key fields.
798 All the fields except the primary key.
806 All fields with unique constraints.
808 =item unique_constraints
810 All this tables unique constraints.
812 =item fkey_constraints
814 All this tables foreign key constraints. (See primary_key method to get the
815 primary key constraint)
823 my @fields = grep { $_->is_primary_key } $me->get_fields;
824 return wantarray ? @fields : \@fields;
827 # ----------------------------------------------------------------------
831 push @fields, $_->fields foreach $me->fkey_constraints;
832 return wantarray ? @fields : \@fields;
835 # ----------------------------------------------------------------------
838 my @fields = grep { !$_->is_primary_key } $me->get_fields;
839 return wantarray ? @fields : \@fields;
842 # ----------------------------------------------------------------------
846 grep { !$_->is_foreign_key and !$_->is_primary_key } $me->get_fields;
847 return wantarray ? @fields : \@fields;
850 # ----------------------------------------------------------------------
854 push @fields, $_->fields foreach $me->unique_constraints;
855 return wantarray ? @fields : \@fields;
858 # ----------------------------------------------------------------------
859 sub unique_constraints {
861 my @cons = grep { $_->type eq UNIQUE } $me->get_constraints;
862 return wantarray ? @cons : \@cons;
865 # ----------------------------------------------------------------------
866 sub fkey_constraints {
868 my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints;
869 return wantarray ? @cons : \@cons;
872 # ----------------------------------------------------------------------
875 undef $self->{'schema'}; # destroy cyclical reference
876 undef $_ for @{ $self->{'constraints'} };
877 undef $_ for @{ $self->{'indices'} };
878 undef $_ for values %{ $self->{'fields'} };
883 # ----------------------------------------------------------------------
889 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
890 Allen Day E<lt>allenday@ucla.eduE<gt>.