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