lib/SQL/Translator/Schema/Table.pm

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