lib/SQL/Translator/Schema/Table.pm

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