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 1.000003;
  23 use SQL::Translator::Utils qw(parse_list_arg ex2err throw);
  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 wantarray ? () : undef;
 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 wantarray ? () : undef;
 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 wantarray ? () : undef;
 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 sub _build_is_trivial_link {
 553     my $self = shift;
 554     return 0 if $self->is_data;
 555
 556     my %fk = ();
 557
 558     foreach my $field ( $self->get_fields ) {
 559      next unless $field->is_foreign_key;
 560      $fk{$field->foreign_key_reference->reference_table}++;
 561    }
 562
 563     foreach my $referenced (keys %fk){
 564    if($fk{$referenced} > 1){
 565        return 0;
 566    }
 567     }
 568
 569     return 1;
 570 }
 571
 572 =head2 is_data
 573
 574 Returns true if the table has some non-key fields.
 575
 576 =cut
 577
 578 has is_data => ( is => 'lazy', init_arg => undef );
 579
 580 sub _build_is_data {
 581     my $self = shift;
 582
 583     foreach my $field ( $self->get_fields ) {
 584         if ( !$field->is_primary_key and !$field->is_foreign_key ) {
 585             return 1;
 586         }
 587     }
 588
 589     return 0;
 590 }
 591
 592 =head2 can_link
 593
 594 Determine whether the table can link two arg tables via many-to-many.
 595
 596   my $ok = $table->can_link($table1,$table2);
 597
 598 =cut
 599
 600 has _can_link => ( is => 'ro', init_arg => undef, default => quote_sub(q{ +{} }) );
 601
 602 sub can_link {
 603     my ( $self, $table1, $table2 ) = @_;
 604
 605     return $self->_can_link->{ $table1->name }{ $table2->name }
 606       if defined $self->_can_link->{ $table1->name }{ $table2->name };
 607
 608     if ( $self->is_data == 1 ) {
 609         $self->_can_link->{ $table1->name }{ $table2->name } = [0];
 610         $self->_can_link->{ $table2->name }{ $table1->name } = [0];
 611         return $self->_can_link->{ $table1->name }{ $table2->name };
 612     }
 613
 614     my %fk = ();
 615
 616     foreach my $field ( $self->get_fields ) {
 617         if ( $field->is_foreign_key ) {
 618             push @{ $fk{ $field->foreign_key_reference->reference_table } },
 619               $field->foreign_key_reference;
 620         }
 621     }
 622
 623     if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
 624     {
 625         $self->_can_link->{ $table1->name }{ $table2->name } = [0];
 626         $self->_can_link->{ $table2->name }{ $table1->name } = [0];
 627         return $self->_can_link->{ $table1->name }{ $table2->name };
 628     }
 629
 630     # trivial traversal, only one way to link the two tables
 631     if (    scalar( @{ $fk{ $table1->name } } == 1 )
 632         and scalar( @{ $fk{ $table2->name } } == 1 ) )
 633     {
 634         $self->_can_link->{ $table1->name }{ $table2->name } =
 635           [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
 636         $self->_can_link->{ $table1->name }{ $table2->name } =
 637           [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
 638
 639         # non-trivial traversal.  one way to link table2,
 640         # many ways to link table1
 641     }
 642     elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
 643         and scalar( @{ $fk{ $table2->name } } == 1 ) )
 644     {
 645         $self->_can_link->{ $table1->name }{ $table2->name } =
 646           [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
 647         $self->_can_link->{ $table2->name }{ $table1->name } =
 648           [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
 649
 650         # non-trivial traversal.  one way to link table1,
 651         # many ways to link table2
 652     }
 653     elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
 654         and scalar( @{ $fk{ $table2->name } } > 1 ) )
 655     {
 656         $self->_can_link->{ $table1->name }{ $table2->name } =
 657           [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
 658         $self->_can_link->{ $table2->name }{ $table1->name } =
 659           [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
 660
 661         # non-trivial traversal.  many ways to link table1 and table2
 662     }
 663     elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
 664         and scalar( @{ $fk{ $table2->name } } > 1 ) )
 665     {
 666         $self->_can_link->{ $table1->name }{ $table2->name } =
 667           [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
 668         $self->_can_link->{ $table2->name }{ $table1->name } =
 669           [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
 670
 671         # one of the tables didn't export a key
 672         # to this table, no linking possible
 673     }
 674     else {
 675         $self->_can_link->{ $table1->name }{ $table2->name } = [0];
 676         $self->_can_link->{ $table2->name }{ $table1->name } = [0];
 677     }
 678
 679     return $self->_can_link->{ $table1->name }{ $table2->name };
 680 }
 681
 682 =head2 name
 683
 684 Get or set the table's name.
 685
 686 Errors ("No table name") if you try to set a blank name.
 687
 688 If provided an argument, checks the schema object for a table of
 689 that name and disallows the change if one exists (setting the error to
 690 "Can't use table name "%s": table exists").
 691
 692   my $table_name = $table->name('foo');
 693
 694 =cut
 695
 696 has name => (
 697     is => 'rw',
 698     isa => sub { throw("No table name") unless $_[0] },
 699 );
 700
 701 around name => sub {
 702     my $orig = shift;
 703     my $self = shift;
 704
 705     if ( my ($arg) = @_ ) {
 706         if ( my $schema = $self->schema ) {
 707             return $self->error( qq[Can't use table name "$arg": table exists] )
 708                 if $schema->get_table( $arg );
 709         }
 710     }
 711
 712     return ex2err($orig, $self, @_);
 713 };
 714
 715 =head2 schema
 716
 717 Get or set the table's schema object.
 718
 719   my $schema = $table->schema;
 720
 721 =cut
 722
 723 has schema => ( is => 'rw', isa => schema_obj('Schema'), weak_ref => 1 );
 724
 725 around schema => \&ex2err;
 726
 727 sub primary_key {
 728
 729 =pod
 730
 731 =head2 primary_key
 732
 733 Gets or sets the table's primary key(s).  Takes one or more field
 734 names (as a string, list or array[ref]) as an argument.  If the field
 735 names are present, it will create a new PK if none exists, or it will
 736 add to the fields of an existing PK (and will unique the field names).
 737 Returns the C<SQL::Translator::Schema::Constraint> object representing
 738 the primary key.
 739
 740 These are eqivalent:
 741
 742   $table->primary_key('id');
 743   $table->primary_key(['name']);
 744   $table->primary_key('id','name']);
 745   $table->primary_key(['id','name']);
 746   $table->primary_key('id,name');
 747   $table->primary_key(qw[ id name ]);
 748
 749   my $pk = $table->primary_key;
 750
 751 =cut
 752
 753     my $self   = shift;
 754     my $fields = parse_list_arg( @_ );
 755
 756     my $constraint;
 757     if ( @$fields ) {
 758         for my $f ( @$fields ) {
 759             return $self->error(qq[Invalid field "$f"]) unless
 760                 $self->get_field($f);
 761         }
 762
 763         my $has_pk;
 764         for my $c ( $self->get_constraints ) {
 765             if ( $c->type eq PRIMARY_KEY ) {
 766                 $has_pk = 1;
 767                 $c->fields( @{ $c->fields }, @$fields );
 768                 $constraint = $c;
 769             }
 770         }
 771
 772         unless ( $has_pk ) {
 773             $constraint = $self->add_constraint(
 774                 type   => PRIMARY_KEY,
 775                 fields => $fields,
 776             ) or return;
 777         }
 778     }
 779
 780     if ( $constraint ) {
 781         return $constraint;
 782     }
 783     else {
 784         for my $c ( $self->get_constraints ) {
 785             return $c if $c->type eq PRIMARY_KEY;
 786         }
 787     }
 788
 789     return;
 790 }
 791
 792 =head2 options
 793
 794 Get or set the table's options (e.g., table types for MySQL).  Returns
 795 an array or array reference.
 796
 797   my @options = $table->options;
 798
 799 =cut
 800
 801 with ListAttr options => ( append => 1 );
 802
 803 =head2 order
 804
 805 Get or set the table's order.
 806
 807   my $order = $table->order(3);
 808
 809 =cut
 810
 811 has order => ( is => 'rw', default => quote_sub(q{ 0 }) );
 812
 813 around order => sub {
 814     my ( $orig, $self, $arg ) = @_;
 815
 816     if ( defined $arg && $arg =~ /^\d+$/ ) {
 817         return $self->$orig($arg);
 818     }
 819
 820     return $self->$orig;
 821 };
 822
 823 =head2 field_names
 824
 825 Read-only method to return a list or array ref of the field names. Returns undef
 826 or an empty list if the table has no fields set. Useful if you want to
 827 avoid the overload magic of the Field objects returned by the get_fields method.
 828
 829   my @names = $constraint->field_names;
 830
 831 =cut
 832
 833 sub field_names {
 834     my $self = shift;
 835     my @fields =
 836         map  { $_->name }
 837         $self->get_fields;
 838
 839     if ( @fields ) {
 840         return wantarray ? @fields : \@fields;
 841     }
 842     else {
 843         $self->error('No fields');
 844         return wantarray ? () : undef;
 845     }
 846 }
 847
 848 sub equals {
 849
 850 =pod
 851
 852 =head2 equals
 853
 854 Determines if this table is the same as another
 855
 856   my $isIdentical = $table1->equals( $table2 );
 857
 858 =cut
 859
 860     my $self = shift;
 861     my $other = shift;
 862     my $case_insensitive = shift;
 863
 864     return 0 unless $self->SUPER::equals($other);
 865     return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
 866     return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
 867     return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
 868
 869     # Fields
 870     # Go through our fields
 871     my %checkedFields;
 872     foreach my $field ( $self->get_fields ) {
 873       my $otherField = $other->get_field($field->name, $case_insensitive);
 874       return 0 unless $field->equals($otherField, $case_insensitive);
 875       $checkedFields{$field->name} = 1;
 876     }
 877     # Go through the other table's fields
 878     foreach my $otherField ( $other->get_fields ) {
 879       next if $checkedFields{$otherField->name};
 880       return 0;
 881     }
 882
 883     # Constraints
 884     # Go through our constraints
 885     my %checkedConstraints;
 886 CONSTRAINT:
 887     foreach my $constraint ( $self->get_constraints ) {
 888       foreach my $otherConstraint ( $other->get_constraints ) {
 889          if ( $constraint->equals($otherConstraint, $case_insensitive) ) {
 890             $checkedConstraints{$otherConstraint} = 1;
 891             next CONSTRAINT;
 892          }
 893       }
 894       return 0;
 895     }
 896     # Go through the other table's constraints
 897 CONSTRAINT2:
 898     foreach my $otherConstraint ( $other->get_constraints ) {
 899       next if $checkedFields{$otherConstraint};
 900       foreach my $constraint ( $self->get_constraints ) {
 901          if ( $otherConstraint->equals($constraint, $case_insensitive) ) {
 902             next CONSTRAINT2;
 903          }
 904       }
 905       return 0;
 906     }
 907
 908     # Indices
 909     # Go through our indices
 910     my %checkedIndices;
 911 INDEX:
 912     foreach my $index ( $self->get_indices ) {
 913       foreach my $otherIndex ( $other->get_indices ) {
 914          if ( $index->equals($otherIndex, $case_insensitive) ) {
 915             $checkedIndices{$otherIndex} = 1;
 916             next INDEX;
 917          }
 918       }
 919       return 0;
 920     }
 921     # Go through the other table's indices
 922 INDEX2:
 923     foreach my $otherIndex ( $other->get_indices ) {
 924       next if $checkedIndices{$otherIndex};
 925       foreach my $index ( $self->get_indices ) {
 926          if ( $otherIndex->equals($index, $case_insensitive) ) {
 927             next INDEX2;
 928          }
 929       }
 930       return 0;
 931     }
 932
 933    return 1;
 934 }
 935
 936 =head1 LOOKUP METHODS
 937
 938 The following are a set of shortcut methods for getting commonly used lists of
 939 fields and constraints. They all return lists or array refs of Field or
 940 Constraint objects.
 941
 942 =over 4
 943
 944 =item pkey_fields
 945
 946 The primary key fields.
 947
 948 =item fkey_fields
 949
 950 All foreign key fields.
 951
 952 =item nonpkey_fields
 953
 954 All the fields except the primary key.
 955
 956 =item data_fields
 957
 958 All non key fields.
 959
 960 =item unique_fields
 961
 962 All fields with unique constraints.
 963
 964 =item unique_constraints
 965
 966 All this tables unique constraints.
 967
 968 =item fkey_constraints
 969
 970 All this tables foreign key constraints. (See primary_key method to get the
 971 primary key constraint)
 972
 973 =back
 974
 975 =cut
 976
 977 sub pkey_fields {
 978     my $me = shift;
 979     my @fields = grep { $_->is_primary_key } $me->get_fields;
 980     return wantarray ? @fields : \@fields;
 981 }
 982
 983 sub fkey_fields {
 984     my $me = shift;
 985     my @fields;
 986     push @fields, $_->fields foreach $me->fkey_constraints;
 987     return wantarray ? @fields : \@fields;
 988 }
 989
 990 sub nonpkey_fields {
 991     my $me = shift;
 992     my @fields = grep { !$_->is_primary_key } $me->get_fields;
 993     return wantarray ? @fields : \@fields;
 994 }
 995
 996 sub data_fields {
 997     my $me = shift;
 998     my @fields =
 999         grep { !$_->is_foreign_key and !$_->is_primary_key } $me->get_fields;
1000     return wantarray ? @fields : \@fields;
1001 }
1002
1003 sub unique_fields {
1004     my $me = shift;
1005     my @fields;
1006     push @fields, $_->fields foreach $me->unique_constraints;
1007     return wantarray ? @fields : \@fields;
1008 }
1009
1010 sub unique_constraints {
1011     my $me = shift;
1012     my @cons = grep { $_->type eq UNIQUE } $me->get_constraints;
1013     return wantarray ? @cons : \@cons;
1014 }
1015
1016 sub fkey_constraints {
1017     my $me = shift;
1018     my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints;
1019     return wantarray ? @cons : \@cons;
1020 }
1021
1022 # Must come after all 'has' declarations
1023 around new => \&ex2err;
1024
1025 1;
1026
1027 =pod
1028
1029 =head1 AUTHORS
1030
1031 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
1032 Allen Day E<lt>allenday@ucla.eduE<gt>.
1033
1034 =cut