lib/SQL/Translator/Schema/Table.pm

   1 package SQL::Translator::Schema::Table;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Table.pm,v 1.23 2003-10-04 01:22:04 kycl4rk Exp $
   5 # ----------------------------------------------------------------------
   6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>
   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 Class::Base;
  44 use SQL::Translator::Utils 'parse_list_arg';
  45 use SQL::Translator::Schema::Constants;
  46 use SQL::Translator::Schema::Constraint;
  47 use SQL::Translator::Schema::Field;
  48 use SQL::Translator::Schema::Index;
  49 use Data::Dumper;
  50
  51 use base 'Class::Base';
  52 use vars qw( $VERSION $FIELD_ORDER );
  53
  54 $VERSION = sprintf "%d.%02d", q$Revision: 1.23 $ =~ /(\d+)\.(\d+)/;
  55
  56 # ----------------------------------------------------------------------
  57 sub init {
  58
  59 =pod
  60
  61 =head2 new
  62
  63 Object constructor.
  64
  65   my $table  =  SQL::Translator::Schema::Table->new(
  66       schema => $schema,
  67       name   => 'foo',
  68   );
  69
  70 =cut
  71
  72     my ( $self, $config ) = @_;
  73
  74     for my $arg ( qw[ schema name comments ] ) {
  75         next unless defined $config->{ $arg };
  76         defined $self->$arg( $config->{ $arg } ) or return;
  77     }
  78
  79     return $self;
  80 }
  81
  82 # ----------------------------------------------------------------------
  83 sub add_constraint {
  84
  85 =pod
  86
  87 =head2 add_constraint
  88
  89 Add a constraint to the table.  Returns the newly created
  90 C<SQL::Translator::Schema::Constraint> object.
  91
  92   my $c1     = $table->add_constraint(
  93       name   => 'pk',
  94       type   => PRIMARY_KEY,
  95       fields => [ 'foo_id' ],
  96   );
  97
  98   my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
  99   $c2    = $table->add_constraint( $constraint );
 100
 101 =cut
 102
 103     my $self             = shift;
 104     my $constraint_class = 'SQL::Translator::Schema::Constraint';
 105     my $constraint;
 106
 107     if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
 108         $constraint = shift;
 109         $constraint->table( $self );
 110     }
 111     else {
 112         my %args = @_;
 113         $args{'table'} = $self;
 114         $constraint = $constraint_class->new( \%args ) or
 115             return $self->error( $constraint_class->error );
 116     }
 117
 118     #
 119     # If we're trying to add a PK when one is already defined,
 120     # then just add the fields to the existing definition.
 121     #
 122     my $ok = 1;
 123     my $pk = $self->primary_key;
 124     if ( $pk && $constraint->type eq PRIMARY_KEY ) {
 125         $self->primary_key( $constraint->fields );
 126         $constraint = $pk;
 127         $ok         = 0;
 128     }
 129     elsif ( $constraint->type eq PRIMARY_KEY ) {
 130         for my $fname ( $constraint->fields ) {
 131             if ( my $f = $self->get_field( $fname ) ) {
 132                 $f->is_primary_key( 1 );
 133             }
 134         }
 135     }
 136     #
 137     # See if another constraint of the same type
 138     # covers the same fields.  -- This doesn't work!  ky
 139     #
 140 #    elsif ( $constraint->type ne CHECK_C ) {
 141 #        my @field_names = $constraint->fields;
 142 #        for my $c (
 143 #            grep { $_->type eq $constraint->type }
 144 #            $self->get_constraints
 145 #        ) {
 146 #            my %fields = map { $_, 1 } $c->fields;
 147 #            for my $field_name ( @field_names ) {
 148 #                if ( $fields{ $field_name } ) {
 149 #                    $constraint = $c;
 150 #                    $ok = 0;
 151 #                    last;
 152 #                }
 153 #            }
 154 #            last unless $ok;
 155 #        }
 156 #    }
 157
 158     if ( $ok ) {
 159         push @{ $self->{'constraints'} }, $constraint;
 160     }
 161
 162     return $constraint;
 163 }
 164
 165 # ----------------------------------------------------------------------
 166 sub add_index {
 167
 168 =pod
 169
 170 =head2 add_index
 171
 172 Add an index to the table.  Returns the newly created
 173 C<SQL::Translator::Schema::Index> object.
 174
 175   my $i1     = $table->add_index(
 176       name   => 'name',
 177       fields => [ 'name' ],
 178       type   => 'normal',
 179   );
 180
 181   my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
 182   $i2    = $table->add_index( $index );
 183
 184 =cut
 185
 186     my $self        = shift;
 187     my $index_class = 'SQL::Translator::Schema::Index';
 188     my $index;
 189
 190     if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
 191         $index = shift;
 192         $index->table( $self );
 193     }
 194     else {
 195         my %args = @_;
 196         $args{'table'} = $self;
 197         $index = $index_class->new( \%args ) or return
 198             $self->error( $index_class->error );
 199     }
 200
 201     push @{ $self->{'indices'} }, $index;
 202     return $index;
 203 }
 204
 205 # ----------------------------------------------------------------------
 206 sub add_field {
 207
 208 =pod
 209
 210 =head2 add_field
 211
 212 Add an field to the table.  Returns the newly created
 213 C<SQL::Translator::Schema::Field> object.  The "name" parameter is
 214 required.  If you try to create a field with the same name as an
 215 existing field, you will get an error and the field will not be created.
 216
 217   my $f1        =  $table->add_field(
 218       name      => 'foo_id',
 219       data_type => 'integer',
 220       size      => 11,
 221   );
 222
 223   my $f2     =  SQL::Translator::Schema::Field->new(
 224       name   => 'name',
 225       table  => $table,
 226   );
 227   $f2 = $table->add_field( $field2 ) or die $table->error;
 228
 229 =cut
 230
 231     my $self        = shift;
 232     my $field_class = 'SQL::Translator::Schema::Field';
 233     my $field;
 234
 235     if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
 236         $field = shift;
 237         $field->table( $self );
 238     }
 239     else {
 240         my %args = @_;
 241         $args{'table'} = $self;
 242         $field = $field_class->new( \%args ) or return
 243             $self->error( $field_class->error );
 244     }
 245
 246     $field->order( ++$FIELD_ORDER );
 247     my $field_name = $field->name or return $self->error('No name');
 248
 249     if ( exists $self->{'fields'}{ $field_name } ) {
 250         return $self->error(qq[Can't create field: "$field_name" exists]);
 251     }
 252     else {
 253         $self->{'fields'}{ $field_name } = $field;
 254     }
 255
 256     return $field;
 257 }
 258
 259 # ----------------------------------------------------------------------
 260 sub comments {
 261
 262 =pod
 263
 264 =head2 comments
 265
 266 Get or set the comments on a table.  May be called several times to
 267 set and it will accumulate the comments.  Called in an array context,
 268 returns each comment individually; called in a scalar context, returns
 269 all the comments joined on newlines.
 270
 271   $table->comments('foo');
 272   $table->comments('bar');
 273   print join( ', ', $table->comments ); # prints "foo, bar"
 274
 275 =cut
 276
 277     my $self     = shift;
 278     my @comments = ref $_[0] ? @{ $_[0] } : @_;
 279
 280     for my $arg ( @comments ) {
 281         $arg = $arg->[0] if ref $arg;
 282         push @{ $self->{'comments'} }, $arg if defined $arg && $arg;
 283     }
 284
 285     if ( @{ $self->{'comments'} || [] } ) {
 286         return wantarray
 287             ? @{ $self->{'comments'} }
 288             : join( "\n", @{ $self->{'comments'} } )
 289         ;
 290     }
 291     else {
 292         return wantarray ? () : undef;
 293     }
 294 }
 295
 296 # ----------------------------------------------------------------------
 297 sub get_constraints {
 298
 299 =pod
 300
 301 =head2 get_constraints
 302
 303 Returns all the constraint objects as an array or array reference.
 304
 305   my @constraints = $table->get_constraints;
 306
 307 =cut
 308
 309     my $self = shift;
 310
 311     if ( ref $self->{'constraints'} ) {
 312         return wantarray
 313             ? @{ $self->{'constraints'} } : $self->{'constraints'};
 314     }
 315     else {
 316         $self->error('No constraints');
 317         return wantarray ? () : undef;
 318     }
 319 }
 320
 321 # ----------------------------------------------------------------------
 322 sub get_indices {
 323
 324 =pod
 325
 326 =head2 get_indices
 327
 328 Returns all the index objects as an array or array reference.
 329
 330   my @indices = $table->get_indices;
 331
 332 =cut
 333
 334     my $self = shift;
 335
 336     if ( ref $self->{'indices'} ) {
 337         return wantarray
 338             ? @{ $self->{'indices'} }
 339             : $self->{'indices'};
 340     }
 341     else {
 342         $self->error('No indices');
 343         return wantarray ? () : undef;
 344     }
 345 }
 346
 347 # ----------------------------------------------------------------------
 348 sub get_field {
 349
 350 =pod
 351
 352 =head2 get_field
 353
 354 Returns a field by the name provided.
 355
 356   my $field = $table->get_field('foo');
 357
 358 =cut
 359
 360     my $self       = shift;
 361     my $field_name = shift or return $self->error('No field name');
 362     return $self->error( qq[Field "$field_name" does not exist] ) unless
 363         exists $self->{'fields'}{ $field_name };
 364     return $self->{'fields'}{ $field_name };
 365 }
 366
 367 # ----------------------------------------------------------------------
 368 sub get_fields {
 369
 370 =pod
 371
 372 =head2 get_fields
 373
 374 Returns all the field objects as an array or array reference.
 375
 376   my @fields = $table->get_fields;
 377
 378 =cut
 379
 380     my $self = shift;
 381     my @fields =
 382         map  { $_->[1] }
 383         sort { $a->[0] <=> $b->[0] }
 384         map  { [ $_->order, $_ ] }
 385         values %{ $self->{'fields'} || {} };
 386
 387     if ( @fields ) {
 388         return wantarray ? @fields : \@fields;
 389     }
 390     else {
 391         $self->error('No fields');
 392         return wantarray ? () : undef;
 393     }
 394 }
 395
 396 # ----------------------------------------------------------------------
 397 sub is_valid {
 398
 399 =pod
 400
 401 =head2 is_valid
 402
 403 Determine whether the view is valid or not.
 404
 405   my $ok = $view->is_valid;
 406
 407 =cut
 408
 409     my $self = shift;
 410     return $self->error('No name')   unless $self->name;
 411     return $self->error('No fields') unless $self->get_fields;
 412
 413     for my $object (
 414         $self->get_fields, $self->get_indices, $self->get_constraints
 415     ) {
 416         return $object->error unless $object->is_valid;
 417     }
 418
 419     return 1;
 420 }
 421
 422 # ----------------------------------------------------------------------
 423 sub is_trivial_link {
 424
 425 =pod
 426
 427 =head2 is_data
 428
 429 =cut
 430
 431     my $self = shift;
 432     return 0 if $self->is_data;
 433     return $self->{'is_trivial_link'} if defined $self->{'is_trivial_link'};
 434
 435     $self->{'is_trivial_link'} = 1;
 436
 437     my %fk = ();
 438
 439     foreach my $field ( $self->get_fields ) {
 440           next unless $field->is_foreign_key;
 441           $fk{$field->foreign_key_reference->reference_table}++;
 442         }
 443
 444     foreach my $referenced (keys %fk){
 445         if($fk{$referenced} > 1){
 446           $self->{'is_trivial_link'} = 0;
 447           last;
 448         }
 449     }
 450
 451     return $self->{'is_trivial_link'};
 452
 453 }
 454
 455 sub is_data {
 456
 457 =pod
 458
 459 =head2 is_data
 460
 461 =cut
 462
 463     my $self = shift;
 464     return $self->{'is_data'} if defined $self->{'is_data'};
 465
 466     $self->{'is_data'} = 0;
 467
 468     foreach my $field ( $self->get_fields ) {
 469         if ( !$field->is_primary_key and !$field->is_foreign_key ) {
 470             $self->{'is_data'} = 1;
 471             return $self->{'is_data'};
 472         }
 473     }
 474
 475     return $self->{'is_data'};
 476 }
 477
 478 # ----------------------------------------------------------------------
 479 sub can_link {
 480
 481 =pod
 482
 483 =head2 can_link
 484
 485 Determine whether the table can link two arg tables via many-to-many.
 486
 487   my $ok = $table->can_link($table1,$table2);
 488
 489 =cut
 490
 491     my ( $self, $table1, $table2 ) = @_;
 492
 493     return $self->{'can_link'}{ $table1->name }{ $table2->name }
 494       if defined $self->{'can_link'}{ $table1->name }{ $table2->name };
 495
 496     if ( $self->is_data == 1 ) {
 497         $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
 498         $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
 499         return $self->{'can_link'}{ $table1->name }{ $table2->name };
 500     }
 501
 502     my %fk = ();
 503
 504     foreach my $field ( $self->get_fields ) {
 505         if ( $field->is_foreign_key ) {
 506             push @{ $fk{ $field->foreign_key_reference->reference_table } },
 507               $field->foreign_key_reference;
 508         }
 509     }
 510
 511     if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
 512     {
 513         $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
 514         $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
 515         return $self->{'can_link'}{ $table1->name }{ $table2->name };
 516     }
 517
 518     # trivial traversal, only one way to link the two tables
 519     if (    scalar( @{ $fk{ $table1->name } } == 1 )
 520         and scalar( @{ $fk{ $table2->name } } == 1 ) )
 521     {
 522         $self->{'can_link'}{ $table1->name }{ $table2->name } =
 523           [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
 524         $self->{'can_link'}{ $table1->name }{ $table2->name } =
 525           [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
 526
 527         # non-trivial traversal.  one way to link table2,
 528         # many ways to link table1
 529     }
 530     elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
 531         and scalar( @{ $fk{ $table2->name } } == 1 ) )
 532     {
 533         $self->{'can_link'}{ $table1->name }{ $table2->name } =
 534           [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
 535         $self->{'can_link'}{ $table2->name }{ $table1->name } =
 536           [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
 537
 538         # non-trivial traversal.  one way to link table1,
 539         # many ways to link table2
 540     }
 541     elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
 542         and scalar( @{ $fk{ $table2->name } } > 1 ) )
 543     {
 544         $self->{'can_link'}{ $table1->name }{ $table2->name } =
 545           [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
 546         $self->{'can_link'}{ $table2->name }{ $table1->name } =
 547           [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
 548
 549         # non-trivial traversal.  many ways to link table1 and table2
 550     }
 551     elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
 552         and scalar( @{ $fk{ $table2->name } } > 1 ) )
 553     {
 554         $self->{'can_link'}{ $table1->name }{ $table2->name } =
 555           [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
 556         $self->{'can_link'}{ $table2->name }{ $table1->name } =
 557           [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
 558
 559         # one of the tables didn't export a key
 560         # to this table, no linking possible
 561     }
 562     else {
 563         $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
 564         $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
 565     }
 566
 567     return $self->{'can_link'}{ $table1->name }{ $table2->name };
 568 }
 569
 570 # ----------------------------------------------------------------------
 571 sub name {
 572
 573 =pod
 574
 575 =head2 name
 576
 577 Get or set the table's name.
 578
 579 If provided an argument, checks the schema object for a table of
 580 that name and disallows the change if one exists.
 581
 582   my $table_name = $table->name('foo');
 583
 584 =cut
 585
 586     my $self = shift;
 587
 588     if ( my $arg = shift ) {
 589         if ( my $schema = $self->schema ) {
 590             return $self->error( qq[Can't use table name "$arg": table exists] )
 591                 if $schema->get_table( $arg );
 592         }
 593         $self->{'name'} = $arg;
 594     }
 595
 596     return $self->{'name'} || '';
 597 }
 598
 599 # ----------------------------------------------------------------------
 600 sub schema {
 601
 602 =pod
 603
 604 =head2 schema
 605
 606 Get or set the table's schema object.
 607
 608   my $schema = $table->schema;
 609
 610 =cut
 611
 612     my $self = shift;
 613     if ( my $arg = shift ) {
 614         return $self->error('Not a schema object') unless
 615             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
 616         $self->{'schema'} = $arg;
 617     }
 618
 619     return $self->{'schema'};
 620 }
 621
 622 # ----------------------------------------------------------------------
 623 sub primary_key {
 624
 625 =pod
 626
 627 =head2 primary_key
 628
 629 Gets or sets the table's primary key(s).  Takes one or more field
 630 names (as a string, list or array[ref]) as an argument.  If the field
 631 names are present, it will create a new PK if none exists, or it will
 632 add to the fields of an existing PK (and will unique the field names).
 633 Returns the C<SQL::Translator::Schema::Constraint> object representing
 634 the primary key.
 635
 636 These are eqivalent:
 637
 638   $table->primary_key('id');
 639   $table->primary_key(['name']);
 640   $table->primary_key('id','name']);
 641   $table->primary_key(['id','name']);
 642   $table->primary_key('id,name');
 643   $table->primary_key(qw[ id name ]);
 644
 645   my $pk = $table->primary_key;
 646
 647 =cut
 648
 649     my $self   = shift;
 650     my $fields = parse_list_arg( @_ );
 651
 652     my $constraint;
 653     if ( @$fields ) {
 654         for my $f ( @$fields ) {
 655             return $self->error(qq[Invalid field "$f"]) unless
 656                 $self->get_field($f);
 657         }
 658
 659         my $has_pk;
 660         for my $c ( $self->get_constraints ) {
 661             if ( $c->type eq PRIMARY_KEY ) {
 662                 $has_pk = 1;
 663                 $c->fields( @{ $c->fields }, @$fields );
 664                 $constraint = $c;
 665             }
 666         }
 667
 668         unless ( $has_pk ) {
 669             $constraint = $self->add_constraint(
 670                 type   => PRIMARY_KEY,
 671                 fields => $fields,
 672             ) or return;
 673         }
 674     }
 675
 676     if ( $constraint ) {
 677         return $constraint;
 678     }
 679     else {
 680         for my $c ( $self->get_constraints ) {
 681             return $c if $c->type eq PRIMARY_KEY;
 682         }
 683     }
 684
 685     return;
 686 }
 687
 688 # ----------------------------------------------------------------------
 689 sub options {
 690
 691 =pod
 692
 693 =head2 options
 694
 695 Get or set the table's options (e.g., table types for MySQL).  Returns
 696 an array or array reference.
 697
 698   my @options = $table->options;
 699
 700 =cut
 701
 702     my $self    = shift;
 703     my $options = parse_list_arg( @_ );
 704
 705     push @{ $self->{'options'} }, @$options;
 706
 707     if ( ref $self->{'options'} ) {
 708         return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
 709     }
 710     else {
 711         return wantarray ? () : [];
 712     }
 713 }
 714
 715 # ----------------------------------------------------------------------
 716 sub order {
 717
 718 =pod
 719
 720 =head2 order
 721
 722 Get or set the table's order.
 723
 724   my $order = $table->order(3);
 725
 726 =cut
 727
 728     my ( $self, $arg ) = @_;
 729
 730     if ( defined $arg && $arg =~ /^\d+$/ ) {
 731         $self->{'order'} = $arg;
 732     }
 733
 734     return $self->{'order'} || 0;
 735 }
 736
 737 # ----------------------------------------------------------------------
 738 sub DESTROY {
 739     my $self = shift;
 740     undef $self->{'schema'}; # destroy cyclical reference
 741     undef $_ for @{ $self->{'constraints'} };
 742     undef $_ for @{ $self->{'indices'} };
 743     undef $_ for values %{ $self->{'fields'} };
 744 }
 745
 746 1;
 747
 748 # ----------------------------------------------------------------------
 749
 750 =pod
 751
 752 =head1 AUTHORS
 753
 754 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
 755 Allen Day E<lt>allenday@ucla.eduE<gt>.
 756
 757 =cut