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