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