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