lib/SQL/Translator/Schema/Table.pm

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