lib/SQL/Translator/Schema/Table.pm

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