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