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