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