lib/SQL/Translator/Schema/Table.pm

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