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