lib/SQL/Translator/Schema/Table.pm

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