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