lib/SQL/Translator/Schema/Table.pm

   1 package SQL::Translator::Schema::Table;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Table.pm,v 1.32 2005-06-28 22:58:06 duality72 Exp $
   5 # ----------------------------------------------------------------------
   6 # Copyright (C) 2002-4 SQLFairy Authors
   7 #
   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.
  11 #
  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.
  16 #
  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
  20 # 02111-1307  USA
  21 # -------------------------------------------------------------------
  22
  23 =pod
  24
  25 =head1 NAME
  26
  27 SQL::Translator::Schema::Table - SQL::Translator table object
  28
  29 =head1 SYNOPSIS
  30
  31   use SQL::Translator::Schema::Table;
  32   my $table = SQL::Translator::Schema::Table->new( name => 'foo' );
  33
  34 =head1 DESCSIPTION
  35
  36 C<SQL::Translator::Schema::Table> is the table object.
  37
  38 =head1 METHODS
  39
  40 =cut
  41
  42 use strict;
  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;
  48 use Data::Dumper;
  49
  50 use base 'SQL::Translator::Schema::Object';
  51
  52 use vars qw( $VERSION $FIELD_ORDER );
  53
  54 $VERSION = sprintf "%d.%02d", q$Revision: 1.32 $ =~ /(\d+)\.(\d+)/;
  55
  56
  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!).
  60 use overload
  61     '""'     => sub { shift->name },
  62     'bool'   => sub { $_[0]->name || $_[0] },
  63     fallback => 1,
  64 ;
  65
  66 # ----------------------------------------------------------------------
  67
  68 __PACKAGE__->_attributes( qw/schema name comments options order/ );
  69
  70 =pod
  71
  72 =head2 new
  73
  74 Object constructor.
  75
  76   my $table  =  SQL::Translator::Schema::Table->new(
  77       schema => $schema,
  78       name   => 'foo',
  79   );
  80
  81 =cut
  82
  83 # ----------------------------------------------------------------------
  84 sub add_constraint {
  85
  86 =pod
  87
  88 =head2 add_constraint
  89
  90 Add a constraint to the table.  Returns the newly created
  91 C<SQL::Translator::Schema::Constraint> object.
  92
  93   my $c1     = $table->add_constraint(
  94       name   => 'pk',
  95       type   => PRIMARY_KEY,
  96       fields => [ 'foo_id' ],
  97   );
  98
  99   my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
 100   $c2    = $table->add_constraint( $constraint );
 101
 102 =cut
 103
 104     my $self             = shift;
 105     my $constraint_class = 'SQL::Translator::Schema::Constraint';
 106     my $constraint;
 107
 108     if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
 109         $constraint = shift;
 110         $constraint->table( $self );
 111     }
 112     else {
 113         my %args = @_;
 114         $args{'table'} = $self;
 115         $constraint = $constraint_class->new( \%args ) or
 116            return $self->error( $constraint_class->error );
 117     }
 118
 119     #
 120     # If we're trying to add a PK when one is already defined,
 121     # then just add the fields to the existing definition.
 122     #
 123     my $ok = 1;
 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;
 130         $constraint = $pk;
 131         $ok         = 0;
 132     }
 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 );
 137             }
 138         }
 139     }
 140     #
 141     # See if another constraint of the same type
 142     # covers the same fields.  -- This doesn't work!  ky
 143     #
 144 #    elsif ( $constraint->type ne CHECK_C ) {
 145 #        my @field_names = $constraint->fields;
 146 #        for my $c (
 147 #            grep { $_->type eq $constraint->type }
 148 #            $self->get_constraints
 149 #        ) {
 150 #            my %fields = map { $_, 1 } $c->fields;
 151 #            for my $field_name ( @field_names ) {
 152 #                if ( $fields{ $field_name } ) {
 153 #                    $constraint = $c;
 154 #                    $ok = 0;
 155 #                    last;
 156 #                }
 157 #            }
 158 #            last unless $ok;
 159 #        }
 160 #    }
 161
 162     if ( $ok ) {
 163         push @{ $self->{'constraints'} }, $constraint;
 164     }
 165
 166     return $constraint;
 167 }
 168
 169 # ----------------------------------------------------------------------
 170 sub drop_constraint {
 171
 172 =pod
 173
 174 =head2 drop_constraint
 175
 176 Remove a constraint from the table. Returns the constraint object if the index
 177 was found and removed, an error otherwise. The single parameter can be either
 178 an index name or an C<SQL::Translator::Schema::Constraint> object.
 179
 180   $table->drop_constraint('myconstraint');
 181
 182 =cut
 183
 184     my $self             = shift;
 185     my $constraint_class = 'SQL::Translator::Schema::Constraint';
 186     my $constraint_name;
 187
 188     if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
 189         $constraint_name = shift->name;
 190     }
 191     else {
 192         $constraint_name = shift;
 193     }
 194
 195     if ( ! grep { $_->name eq $constraint_name } @ { $self->{'constraints'} } ) {
 196         return $self->error(qq[Can't drop constraint: "$constraint_name" doesn't exist]);
 197     }
 198
 199     my @cs = @{ $self->{'constraints'} };
 200     my ($constraint_id) = grep { $cs[$_]->name eq  $constraint_name } (0..$#cs);
 201     my $constraint = splice(@{$self->{'constraints'}}, $constraint_id, 1);
 202
 203     return $constraint;
 204 }
 205
 206 # ----------------------------------------------------------------------
 207 sub add_index {
 208
 209 =pod
 210
 211 =head2 add_index
 212
 213 Add an index to the table.  Returns the newly created
 214 C<SQL::Translator::Schema::Index> object.
 215
 216   my $i1     = $table->add_index(
 217       name   => 'name',
 218       fields => [ 'name' ],
 219       type   => 'normal',
 220   );
 221
 222   my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
 223   $i2    = $table->add_index( $index );
 224
 225 =cut
 226
 227     my $self        = shift;
 228     my $index_class = 'SQL::Translator::Schema::Index';
 229     my $index;
 230
 231     if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
 232         $index = shift;
 233         $index->table( $self );
 234     }
 235     else {
 236         my %args = @_;
 237         $args{'table'} = $self;
 238         $index = $index_class->new( \%args ) or return
 239             $self->error( $index_class->error );
 240     }
 241
 242     push @{ $self->{'indices'} }, $index;
 243     return $index;
 244 }
 245
 246 # ----------------------------------------------------------------------
 247 sub drop_index {
 248
 249 =pod
 250
 251 =head2 drop_index
 252
 253 Remove an index from the table. Returns the index object if the index was
 254 found and removed, an error otherwise. The single parameter can be either
 255 an index name of an C<SQL::Translator::Schema::Index> object.
 256
 257   $table->drop_index('myindex');
 258
 259 =cut
 260
 261     my $self        = shift;
 262     my $index_class = 'SQL::Translator::Schema::Index';
 263     my $index_name;
 264
 265     if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
 266         $index_name = shift->name;
 267     }
 268     else {
 269         $index_name = shift;
 270     }
 271
 272     if ( ! grep { $_->name eq  $index_name } @{ $self->{'indices'} }) {
 273         return $self->error(qq[Can't drop index: "$index_name" doesn't exist]);
 274     }
 275
 276     my @is = @{ $self->{'indices'} };
 277     my ($index_id) = grep { $is[$_]->name eq  $index_name } (0..$#is);
 278     my $index = splice(@{$self->{'indices'}}, $index_id, 1);
 279
 280     return $index;
 281 }
 282
 283 # ----------------------------------------------------------------------
 284 sub add_field {
 285
 286 =pod
 287
 288 =head2 add_field
 289
 290 Add an field to the table.  Returns the newly created
 291 C<SQL::Translator::Schema::Field> object.  The "name" parameter is
 292 required.  If you try to create a field with the same name as an
 293 existing field, you will get an error and the field will not be created.
 294
 295   my $f1        =  $table->add_field(
 296       name      => 'foo_id',
 297       data_type => 'integer',
 298       size      => 11,
 299   );
 300
 301   my $f2     =  SQL::Translator::Schema::Field->new(
 302       name   => 'name',
 303       table  => $table,
 304   );
 305   $f2 = $table->add_field( $field2 ) or die $table->error;
 306
 307 =cut
 308
 309     my $self        = shift;
 310     my $field_class = 'SQL::Translator::Schema::Field';
 311     my $field;
 312
 313     if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
 314         $field = shift;
 315         $field->table( $self );
 316     }
 317     else {
 318         my %args = @_;
 319         $args{'table'} = $self;
 320         $field = $field_class->new( \%args ) or return
 321             $self->error( $field_class->error );
 322     }
 323
 324     $field->order( ++$FIELD_ORDER );
 325     # We know we have a name as the Field->new above errors if none given.
 326     my $field_name = $field->name;
 327
 328     if ( exists $self->{'fields'}{ $field_name } ) {
 329         return $self->error(qq[Can't create field: "$field_name" exists]);
 330     }
 331     else {
 332         $self->{'fields'}{ $field_name } = $field;
 333     }
 334
 335     return $field;
 336 }
 337 # ----------------------------------------------------------------------
 338 sub drop_field {
 339
 340 =pod
 341
 342 =head2 drop_field
 343
 344 Remove a field from the table. Returns the field object if the field was
 345 found and removed, an error otherwise. The single parameter can be either
 346 a field name or an C<SQL::Translator::Schema::Field> object.
 347
 348   $table->drop_field('myfield');
 349
 350 =cut
 351
 352     my $self        = shift;
 353     my $field_class = 'SQL::Translator::Schema::Field';
 354     my $field_name;
 355
 356     if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
 357         $field_name = shift->name;
 358     }
 359     else {
 360         $field_name = shift;
 361     }
 362     my %args = @_;
 363     my $cascade = $args{'cascade'};
 364
 365     if ( ! exists $self->{'fields'}{ $field_name } ) {
 366         return $self->error(qq[Can't drop field: "$field_name" doesn't exists]);
 367     }
 368
 369     my $field = delete $self->{'fields'}{ $field_name };
 370
 371     if ( $cascade ) {
 372         # Remove this field from all indices using it
 373         foreach my $i ($self->get_indices()) {
 374             my @fs = $i->fields();
 375             @fs = grep { $_ ne $field->name } @fs;
 376             $i->fields(@fs);
 377         }
 378
 379         # Remove this field from all constraints using it
 380         foreach my $c ($self->get_constraints()) {
 381             my @cs = $c->fields();
 382             @cs = grep { $_ ne $field->name } @cs;
 383             $c->fields(@cs);
 384         }
 385     }
 386
 387     return $field;
 388 }
 389
 390 # ----------------------------------------------------------------------
 391 sub comments {
 392
 393 =pod
 394
 395 =head2 comments
 396
 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.
 401
 402   $table->comments('foo');
 403   $table->comments('bar');
 404   print join( ', ', $table->comments ); # prints "foo, bar"
 405
 406 =cut
 407
 408     my $self     = shift;
 409     my @comments = ref $_[0] ? @{ $_[0] } : @_;
 410
 411     for my $arg ( @comments ) {
 412         $arg = $arg->[0] if ref $arg;
 413         push @{ $self->{'comments'} }, $arg if defined $arg && $arg;
 414     }
 415
 416     if ( @{ $self->{'comments'} || [] } ) {
 417         return wantarray
 418             ? @{ $self->{'comments'} }
 419             : join( "\n", @{ $self->{'comments'} } )
 420         ;
 421     }
 422     else {
 423         return wantarray ? () : undef;
 424     }
 425 }
 426
 427 # ----------------------------------------------------------------------
 428 sub get_constraints {
 429
 430 =pod
 431
 432 =head2 get_constraints
 433
 434 Returns all the constraint objects as an array or array reference.
 435
 436   my @constraints = $table->get_constraints;
 437
 438 =cut
 439
 440     my $self = shift;
 441
 442     if ( ref $self->{'constraints'} ) {
 443         return wantarray
 444             ? @{ $self->{'constraints'} } : $self->{'constraints'};
 445     }
 446     else {
 447         $self->error('No constraints');
 448         return wantarray ? () : undef;
 449     }
 450 }
 451
 452 # ----------------------------------------------------------------------
 453 sub get_indices {
 454
 455 =pod
 456
 457 =head2 get_indices
 458
 459 Returns all the index objects as an array or array reference.
 460
 461   my @indices = $table->get_indices;
 462
 463 =cut
 464
 465     my $self = shift;
 466
 467     if ( ref $self->{'indices'} ) {
 468         return wantarray
 469             ? @{ $self->{'indices'} }
 470             : $self->{'indices'};
 471     }
 472     else {
 473         $self->error('No indices');
 474         return wantarray ? () : undef;
 475     }
 476 }
 477
 478 # ----------------------------------------------------------------------
 479 sub get_field {
 480
 481 =pod
 482
 483 =head2 get_field
 484
 485 Returns a field by the name provided.
 486
 487   my $field = $table->get_field('foo');
 488
 489 =cut
 490
 491     my $self       = shift;
 492     my $field_name = shift or return $self->error('No field name');
 493     return $self->error( qq[Field "$field_name" does not exist] ) unless
 494         exists $self->{'fields'}{ $field_name };
 495     return $self->{'fields'}{ $field_name };
 496 }
 497
 498 # ----------------------------------------------------------------------
 499 sub get_fields {
 500
 501 =pod
 502
 503 =head2 get_fields
 504
 505 Returns all the field objects as an array or array reference.
 506
 507   my @fields = $table->get_fields;
 508
 509 =cut
 510
 511     my $self = shift;
 512     my @fields =
 513         map  { $_->[1] }
 514         sort { $a->[0] <=> $b->[0] }
 515         map  { [ $_->order, $_ ] }
 516         values %{ $self->{'fields'} || {} };
 517
 518     if ( @fields ) {
 519         return wantarray ? @fields : \@fields;
 520     }
 521     else {
 522         $self->error('No fields');
 523         return wantarray ? () : undef;
 524     }
 525 }
 526
 527 # ----------------------------------------------------------------------
 528 sub is_valid {
 529
 530 =pod
 531
 532 =head2 is_valid
 533
 534 Determine whether the view is valid or not.
 535
 536   my $ok = $view->is_valid;
 537
 538 =cut
 539
 540     my $self = shift;
 541     return $self->error('No name')   unless $self->name;
 542     return $self->error('No fields') unless $self->get_fields;
 543
 544     for my $object (
 545         $self->get_fields, $self->get_indices, $self->get_constraints
 546     ) {
 547         return $object->error unless $object->is_valid;
 548     }
 549
 550     return 1;
 551 }
 552
 553 # ----------------------------------------------------------------------
 554 sub is_trivial_link {
 555
 556 =pod
 557
 558 =head2 is_trivial_link
 559
 560 True if table has no data (non-key) fields and only uses single key joins.
 561
 562 =cut
 563
 564     my $self = shift;
 565     return 0 if $self->is_data;
 566     return $self->{'is_trivial_link'} if defined $self->{'is_trivial_link'};
 567
 568     $self->{'is_trivial_link'} = 1;
 569
 570     my %fk = ();
 571
 572     foreach my $field ( $self->get_fields ) {
 573           next unless $field->is_foreign_key;
 574           $fk{$field->foreign_key_reference->reference_table}++;
 575         }
 576
 577     foreach my $referenced (keys %fk){
 578         if($fk{$referenced} > 1){
 579           $self->{'is_trivial_link'} = 0;
 580           last;
 581         }
 582     }
 583
 584     return $self->{'is_trivial_link'};
 585
 586 }
 587
 588 sub is_data {
 589
 590 =pod
 591
 592 =head2 is_data
 593
 594 Returns true if the table has some non-key fields.
 595
 596 =cut
 597
 598     my $self = shift;
 599     return $self->{'is_data'} if defined $self->{'is_data'};
 600
 601     $self->{'is_data'} = 0;
 602
 603     foreach my $field ( $self->get_fields ) {
 604         if ( !$field->is_primary_key and !$field->is_foreign_key ) {
 605             $self->{'is_data'} = 1;
 606             return $self->{'is_data'};
 607         }
 608     }
 609
 610     return $self->{'is_data'};
 611 }
 612
 613 # ----------------------------------------------------------------------
 614 sub can_link {
 615
 616 =pod
 617
 618 =head2 can_link
 619
 620 Determine whether the table can link two arg tables via many-to-many.
 621
 622   my $ok = $table->can_link($table1,$table2);
 623
 624 =cut
 625
 626     my ( $self, $table1, $table2 ) = @_;
 627
 628     return $self->{'can_link'}{ $table1->name }{ $table2->name }
 629       if defined $self->{'can_link'}{ $table1->name }{ $table2->name };
 630
 631     if ( $self->is_data == 1 ) {
 632         $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
 633         $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
 634         return $self->{'can_link'}{ $table1->name }{ $table2->name };
 635     }
 636
 637     my %fk = ();
 638
 639     foreach my $field ( $self->get_fields ) {
 640         if ( $field->is_foreign_key ) {
 641             push @{ $fk{ $field->foreign_key_reference->reference_table } },
 642               $field->foreign_key_reference;
 643         }
 644     }
 645
 646     if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
 647     {
 648         $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
 649         $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
 650         return $self->{'can_link'}{ $table1->name }{ $table2->name };
 651     }
 652
 653     # trivial traversal, only one way to link the two tables
 654     if (    scalar( @{ $fk{ $table1->name } } == 1 )
 655         and scalar( @{ $fk{ $table2->name } } == 1 ) )
 656     {
 657         $self->{'can_link'}{ $table1->name }{ $table2->name } =
 658           [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
 659         $self->{'can_link'}{ $table1->name }{ $table2->name } =
 660           [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
 661
 662         # non-trivial traversal.  one way to link table2,
 663         # many ways to link table1
 664     }
 665     elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
 666         and scalar( @{ $fk{ $table2->name } } == 1 ) )
 667     {
 668         $self->{'can_link'}{ $table1->name }{ $table2->name } =
 669           [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
 670         $self->{'can_link'}{ $table2->name }{ $table1->name } =
 671           [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
 672
 673         # non-trivial traversal.  one way to link table1,
 674         # many ways to link table2
 675     }
 676     elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
 677         and scalar( @{ $fk{ $table2->name } } > 1 ) )
 678     {
 679         $self->{'can_link'}{ $table1->name }{ $table2->name } =
 680           [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
 681         $self->{'can_link'}{ $table2->name }{ $table1->name } =
 682           [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
 683
 684         # non-trivial traversal.  many ways to link table1 and table2
 685     }
 686     elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
 687         and scalar( @{ $fk{ $table2->name } } > 1 ) )
 688     {
 689         $self->{'can_link'}{ $table1->name }{ $table2->name } =
 690           [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
 691         $self->{'can_link'}{ $table2->name }{ $table1->name } =
 692           [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
 693
 694         # one of the tables didn't export a key
 695         # to this table, no linking possible
 696     }
 697     else {
 698         $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
 699         $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
 700     }
 701
 702     return $self->{'can_link'}{ $table1->name }{ $table2->name };
 703 }
 704
 705 # ----------------------------------------------------------------------
 706 sub name {
 707
 708 =pod
 709
 710 =head2 name
 711
 712 Get or set the table's name.
 713
 714 Errors ("No table name") if you try to set a blank name.
 715
 716 If provided an argument, checks the schema object for a table of
 717 that name and disallows the change if one exists (setting the error to
 718 "Can't use table name "%s": table exists").
 719
 720   my $table_name = $table->name('foo');
 721
 722 =cut
 723
 724     my $self = shift;
 725
 726     if ( @_ ) {
 727         my $arg = shift || return $self->error( "No table name" );
 728         if ( my $schema = $self->schema ) {
 729             return $self->error( qq[Can't use table name "$arg": table exists] )
 730                 if $schema->get_table( $arg );
 731         }
 732         $self->{'name'} = $arg;
 733     }
 734
 735     return $self->{'name'} || '';
 736 }
 737
 738 # ----------------------------------------------------------------------
 739 sub schema {
 740
 741 =pod
 742
 743 =head2 schema
 744
 745 Get or set the table's schema object.
 746
 747   my $schema = $table->schema;
 748
 749 =cut
 750
 751     my $self = shift;
 752     if ( my $arg = shift ) {
 753         return $self->error('Not a schema object') unless
 754             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
 755         $self->{'schema'} = $arg;
 756     }
 757
 758     return $self->{'schema'};
 759 }
 760
 761 # ----------------------------------------------------------------------
 762 sub primary_key {
 763
 764 =pod
 765
 766 =head2 primary_key
 767
 768 Gets or sets the table's primary key(s).  Takes one or more field
 769 names (as a string, list or array[ref]) as an argument.  If the field
 770 names are present, it will create a new PK if none exists, or it will
 771 add to the fields of an existing PK (and will unique the field names).
 772 Returns the C<SQL::Translator::Schema::Constraint> object representing
 773 the primary key.
 774
 775 These are eqivalent:
 776
 777   $table->primary_key('id');
 778   $table->primary_key(['name']);
 779   $table->primary_key('id','name']);
 780   $table->primary_key(['id','name']);
 781   $table->primary_key('id,name');
 782   $table->primary_key(qw[ id name ]);
 783
 784   my $pk = $table->primary_key;
 785
 786 =cut
 787
 788     my $self   = shift;
 789     my $fields = parse_list_arg( @_ );
 790
 791     my $constraint;
 792     if ( @$fields ) {
 793         for my $f ( @$fields ) {
 794             return $self->error(qq[Invalid field "$f"]) unless
 795                 $self->get_field($f);
 796         }
 797
 798         my $has_pk;
 799         for my $c ( $self->get_constraints ) {
 800             if ( $c->type eq PRIMARY_KEY ) {
 801                 $has_pk = 1;
 802                 $c->fields( @{ $c->fields }, @$fields );
 803                 $constraint = $c;
 804             }
 805         }
 806
 807         unless ( $has_pk ) {
 808             $constraint = $self->add_constraint(
 809                 type   => PRIMARY_KEY,
 810                 fields => $fields,
 811             ) or return;
 812         }
 813     }
 814
 815     if ( $constraint ) {
 816         return $constraint;
 817     }
 818     else {
 819         for my $c ( $self->get_constraints ) {
 820             return $c if $c->type eq PRIMARY_KEY;
 821         }
 822     }
 823
 824     return;
 825 }
 826
 827 # ----------------------------------------------------------------------
 828 sub options {
 829
 830 =pod
 831
 832 =head2 options
 833
 834 Get or set the table's options (e.g., table types for MySQL).  Returns
 835 an array or array reference.
 836
 837   my @options = $table->options;
 838
 839 =cut
 840
 841     my $self    = shift;
 842     my $options = parse_list_arg( @_ );
 843
 844     push @{ $self->{'options'} }, @$options;
 845
 846     if ( ref $self->{'options'} ) {
 847         return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
 848     }
 849     else {
 850         return wantarray ? () : [];
 851     }
 852 }
 853
 854 # ----------------------------------------------------------------------
 855 sub order {
 856
 857 =pod
 858
 859 =head2 order
 860
 861 Get or set the table's order.
 862
 863   my $order = $table->order(3);
 864
 865 =cut
 866
 867     my ( $self, $arg ) = @_;
 868
 869     if ( defined $arg && $arg =~ /^\d+$/ ) {
 870         $self->{'order'} = $arg;
 871     }
 872
 873     return $self->{'order'} || 0;
 874 }
 875
 876 # ----------------------------------------------------------------------
 877 sub field_names {
 878
 879 =head2 field_names
 880
 881 Read-only method to return a list or array ref of the field names. Returns undef
 882 or an empty list if the table has no fields set. Usefull if you want to
 883 avoid the overload magic of the Field objects returned by the get_fields method.
 884
 885   my @names = $constraint->field_names;
 886
 887 =cut
 888
 889     my $self = shift;
 890     my @fields =
 891         map  { $_->name }
 892         sort { $a->order <=> $b->order }
 893         values %{ $self->{'fields'} || {} };
 894
 895     if ( @fields ) {
 896         return wantarray ? @fields : \@fields;
 897     }
 898     else {
 899         $self->error('No fields');
 900         return wantarray ? () : undef;
 901     }
 902 }
 903
 904 # ----------------------------------------------------------------------
 905 sub equals {
 906
 907 =pod
 908
 909 =head2 equals
 910
 911 Determines if this table is the same as another
 912
 913   my $isIdentical = $table1->equals( $table2 );
 914
 915 =cut
 916
 917     my $self = shift;
 918     my $other = shift;
 919
 920     return 0 unless $self->SUPER::equals($other);
 921     return 0 unless $self->name eq $other->name;
 922     return 0 unless $self->_compare_objects($self->options, $other->options);
 923     return 0 unless $self->_compare_objects($self->extra, $other->extra);
 924
 925     # Fields
 926     # Go through our fields
 927     my %checkedFields;
 928     foreach my $field ( $self->get_fields ) {
 929         my $otherField = $other->get_field($field->name);
 930         return 0 unless $field->equals($otherField);
 931         $checkedFields{$field->name} = 1;
 932     }
 933     # Go through the other table's fields
 934     foreach my $otherField ( $other->get_fields ) {
 935         next if $checkedFields{$otherField->name};
 936         return 0;
 937     }
 938
 939     # Constraints
 940     # Go through our constraints
 941     my %checkedConstraints;
 942 CONSTRAINT:
 943     foreach my $constraint ( $self->get_constraints ) {
 944         foreach my $otherConstraint ( $other->get_constraints ) {
 945                 if ( $constraint->equals($otherConstraint) ) {
 946                         $checkedConstraints{$otherConstraint} = 1;
 947                         next CONSTRAINT;
 948                 }
 949         }
 950         return 0;
 951     }
 952     # Go through the other table's constraints
 953 CONSTRAINT2:
 954     foreach my $otherConstraint ( $other->get_constraints ) {
 955         next if $checkedFields{$otherConstraint};
 956         foreach my $constraint ( $self->get_constraints ) {
 957                 if ( $otherConstraint->equals($constraint) ) {
 958                         next CONSTRAINT2;
 959                 }
 960         }
 961         return 0;
 962     }
 963
 964     # Indices
 965     # Go through our indices
 966     my %checkedIndices;
 967 INDEX:
 968     foreach my $index ( $self->get_indices ) {
 969         foreach my $otherIndex ( $other->get_indices ) {
 970                 if ( $index->equals($otherIndex) ) {
 971                         $checkedIndices{$otherIndex} = 1;
 972                         next INDEX;
 973                 }
 974         }
 975         return 0;
 976     }
 977     # Go through the other table's indices
 978 INDEX2:
 979     foreach my $otherIndex ( $other->get_indices ) {
 980         next if $checkedIndices{$otherIndex};
 981         foreach my $index ( $self->get_indices ) {
 982                 if ( $otherIndex->equals($index) ) {
 983                         next INDEX2;
 984                 }
 985         }
 986         return 0;
 987     }
 988
 989         return 1;
 990 }
 991
 992 # ----------------------------------------------------------------------
 993
 994 =head1 LOOKUP METHODS
 995
 996 The following are a set of shortcut methods for getting commonly used lists of
 997 fields and constraints. They all return lists or array refs of Field or
 998 Constraint objects.
 999
1000 =over 4
1001
1002 =item pkey_fields
1003
1004 The primary key fields.
1005
1006 =item fkey_fields
1007
1008 All foreign key fields.
1009
1010 =item nonpkey_fields
1011
1012 All the fields except the primary key.
1013
1014 =item data_fields
1015
1016 All non key fields.
1017
1018 =item unique_fields
1019
1020 All fields with unique constraints.
1021
1022 =item unique_constraints
1023
1024 All this tables unique constraints.
1025
1026 =item fkey_constraints
1027
1028 All this tables foreign key constraints. (See primary_key method to get the
1029 primary key constraint)
1030
1031 =back
1032
1033 =cut
1034
1035 sub pkey_fields {
1036     my $me = shift;
1037     my @fields = grep { $_->is_primary_key } $me->get_fields;
1038     return wantarray ? @fields : \@fields;
1039 }
1040
1041 # ----------------------------------------------------------------------
1042 sub fkey_fields {
1043     my $me = shift;
1044     my @fields;
1045     push @fields, $_->fields foreach $me->fkey_constraints;
1046     return wantarray ? @fields : \@fields;
1047 }
1048
1049 # ----------------------------------------------------------------------
1050 sub nonpkey_fields {
1051     my $me = shift;
1052     my @fields = grep { !$_->is_primary_key } $me->get_fields;
1053     return wantarray ? @fields : \@fields;
1054 }
1055
1056 # ----------------------------------------------------------------------
1057 sub data_fields {
1058     my $me = shift;
1059     my @fields =
1060         grep { !$_->is_foreign_key and !$_->is_primary_key } $me->get_fields;
1061     return wantarray ? @fields : \@fields;
1062 }
1063
1064 # ----------------------------------------------------------------------
1065 sub unique_fields {
1066     my $me = shift;
1067     my @fields;
1068     push @fields, $_->fields foreach $me->unique_constraints;
1069     return wantarray ? @fields : \@fields;
1070 }
1071
1072 # ----------------------------------------------------------------------
1073 sub unique_constraints {
1074     my $me = shift;
1075     my @cons = grep { $_->type eq UNIQUE } $me->get_constraints;
1076     return wantarray ? @cons : \@cons;
1077 }
1078
1079 # ----------------------------------------------------------------------
1080 sub fkey_constraints {
1081     my $me = shift;
1082     my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints;
1083     return wantarray ? @cons : \@cons;
1084 }
1085
1086 # ----------------------------------------------------------------------
1087 sub DESTROY {
1088     my $self = shift;
1089     undef $self->{'schema'}; # destroy cyclical reference
1090     undef $_ for @{ $self->{'constraints'} };
1091     undef $_ for @{ $self->{'indices'} };
1092     undef $_ for values %{ $self->{'fields'} };
1093 }
1094
1095 1;
1096
1097 # ----------------------------------------------------------------------
1098
1099 =pod
1100
1101 =head1 AUTHORS
1102
1103 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
1104 Allen Day E<lt>allenday@ucla.eduE<gt>.
1105
1106 =cut