lib/SQL/Translator/Schema/Table.pm

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