lib/SQL/Translator/Schema/Table.pm

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