lib/SQL/Translator/Schema/Table.pm

   1 package SQL::Translator::Schema::Table;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Table.pm,v 1.14 2003-08-21 20:27: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
  50 use base 'Class::Base';
  51 use vars qw( $VERSION $FIELD_ORDER );
  52
  53 $VERSION = sprintf "%d.%02d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/;
  54
  55 # ----------------------------------------------------------------------
  56 sub init {
  57
  58 =pod
  59
  60 =head2 new
  61
  62 Object constructor.
  63
  64   my $table  =  SQL::Translator::Schema::Table->new(
  65       schema => $schema,
  66       name   => 'foo',
  67   );
  68
  69 =cut
  70
  71     my ( $self, $config ) = @_;
  72
  73     for my $arg ( qw[ schema name comments ] ) {
  74         next unless defined $config->{ $arg };
  75         defined $self->$arg( $config->{ $arg } ) or return;
  76     }
  77
  78     return $self;
  79 }
  80
  81 # ----------------------------------------------------------------------
  82 sub add_constraint {
  83
  84 =pod
  85
  86 =head2 add_constraint
  87
  88 Add a constraint to the table.  Returns the newly created
  89 C<SQL::Translator::Schema::Constraint> object.
  90
  91   my $c1 = $table->add_constraint(
  92       name        => 'pk',
  93       type        => PRIMARY_KEY,
  94       fields      => [ 'foo_id' ],
  95   );
  96
  97   my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
  98   $c2    = $table->add_constraint( $constraint );
  99
 100 =cut
 101
 102     my $self             = shift;
 103     my $constraint_class = 'SQL::Translator::Schema::Constraint';
 104     my $constraint;
 105
 106     if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
 107         $constraint = shift;
 108         $constraint->table( $self );
 109     }
 110     else {
 111         my %args = @_;
 112         $args{'table'} = $self;
 113         $constraint = $constraint_class->new( \%args ) or
 114             return $self->error( $constraint_class->error );
 115     }
 116
 117     #
 118     # If we're trying to add a PK when one is already defined,
 119     # then just add the fields to the existing definition.
 120     #
 121     my $ok = 1;
 122     my $pk = $self->primary_key;
 123     if ( $pk && $constraint->type eq PRIMARY_KEY ) {
 124         $self->primary_key( $constraint->fields );
 125         $constraint = $pk;
 126         $ok         = 0;
 127     }
 128     elsif ( $constraint->type eq PRIMARY_KEY ) {
 129         for my $fname ( $constraint->fields ) {
 130             if ( my $f = $self->get_field( $fname ) ) {
 131                 $f->is_primary_key( 1 );
 132             }
 133         }
 134     }
 135     #
 136     # See if another constraint of the same type
 137     # covers the same fields.
 138     #
 139     elsif ( $constraint->type ne CHECK_C ) {
 140         my @field_names = $constraint->fields;
 141         for my $c (
 142             grep { $_->type eq $constraint->type }
 143             $self->get_constraints
 144         ) {
 145             my %fields = map { $_, 1 } $c->fields;
 146             for my $field_name ( @field_names ) {
 147                 if ( $fields{ $field_name } ) {
 148                     $constraint = $c;
 149                     $ok = 0;
 150                     last;
 151                 }
 152             }
 153             last unless $ok;
 154         }
 155     }
 156
 157     if ( $ok ) {
 158         push @{ $self->{'constraints'} }, $constraint;
 159     }
 160
 161     return $constraint;
 162 }
 163
 164 # ----------------------------------------------------------------------
 165 sub add_index {
 166
 167 =pod
 168
 169 =head2 add_index
 170
 171 Add an index to the table.  Returns the newly created
 172 C<SQL::Translator::Schema::Index> object.
 173
 174   my $i1 = $table->add_index(
 175       name   => 'name',
 176       fields => [ 'name' ],
 177       type   => 'normal',
 178   );
 179
 180   my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
 181   $i2    = $table->add_index( $index );
 182
 183 =cut
 184
 185     my $self        = shift;
 186     my $index_class = 'SQL::Translator::Schema::Index';
 187     my $index;
 188
 189     if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
 190         $index = shift;
 191         $index->table( $self );
 192     }
 193     else {
 194         my %args = @_;
 195         $args{'table'} = $self;
 196         $index = $index_class->new( \%args ) or return
 197             $self->error( $index_class->error );
 198     }
 199
 200     push @{ $self->{'indices'} }, $index;
 201     return $index;
 202 }
 203
 204 # ----------------------------------------------------------------------
 205 sub add_field {
 206
 207 =pod
 208
 209 =head2 add_field
 210
 211 Add an field to the table.  Returns the newly created
 212 C<SQL::Translator::Schema::Field> object.  The "name" parameter is
 213 required.  If you try to create a field with the same name as an
 214 existing field, you will get an error and the field will not be created.
 215
 216   my $f1    =  $table->add_field(
 217       name      => 'foo_id',
 218       data_type => 'integer',
 219       size      => 11,
 220   );
 221
 222   my $f2 =  SQL::Translator::Schema::Field->new(
 223       name   => 'name',
 224       table  => $table,
 225   );
 226   $f2    = $table->add_field( $field2 ) or die $table->error;
 227
 228 =cut
 229
 230     my $self        = shift;
 231     my $field_class = 'SQL::Translator::Schema::Field';
 232     my $field;
 233
 234     if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
 235         $field = shift;
 236         $field->table( $self );
 237     }
 238     else {
 239         my %args = @_;
 240         $args{'table'} = $self;
 241         $field = $field_class->new( \%args ) or return
 242             $self->error( $field_class->error );
 243     }
 244
 245     $field->order( ++$FIELD_ORDER );
 246     my $field_name = $field->name or return $self->error('No name');
 247
 248     if ( exists $self->{'fields'}{ $field_name } ) {
 249         return $self->error(qq[Can't create field: "$field_name" exists]);
 250     }
 251     else {
 252         $self->{'fields'}{ $field_name } = $field;
 253     }
 254
 255     return $field;
 256 }
 257
 258 # ----------------------------------------------------------------------
 259 sub comments {
 260
 261 =pod
 262
 263 =head2 comments
 264
 265 Get or set the comments on a table.  May be called several times to
 266 set and it will accumulate the comments.  Called in an array context,
 267 returns each comment individually; called in a scalar context, returns
 268 all the comments joined on newlines.
 269
 270   $table->comments('foo');
 271   $table->comments('bar');
 272   print join( ', ', $table->comments ); # prints "foo, bar"
 273
 274 =cut
 275
 276     my $self     = shift;
 277     my @comments = ref $_[0] ? @{ $_[0] } : @_;
 278
 279     for my $arg ( @comments ) {
 280         $arg = $arg->[0] if ref $arg;
 281         push @{ $self->{'comments'} }, $arg if defined $arg && $arg;
 282     }
 283
 284     if ( @{ $self->{'comments'} || [] } ) {
 285         return wantarray
 286             ? @{ $self->{'comments'} }
 287             : join( "\n", @{ $self->{'comments'} } )
 288         ;
 289     }
 290     else {
 291         return wantarray ? () : undef;
 292     }
 293 }
 294
 295 # ----------------------------------------------------------------------
 296 sub get_constraints {
 297
 298 =pod
 299
 300 =head2 get_constraints
 301
 302 Returns all the constraint objects as an array or array reference.
 303
 304   my @constraints = $table->get_constraints;
 305
 306 =cut
 307
 308     my $self = shift;
 309
 310     if ( ref $self->{'constraints'} ) {
 311         return wantarray
 312             ? @{ $self->{'constraints'} } : $self->{'constraints'};
 313     }
 314     else {
 315         $self->error('No constraints');
 316         return wantarray ? () : undef;
 317     }
 318 }
 319
 320 # ----------------------------------------------------------------------
 321 sub get_indices {
 322
 323 =pod
 324
 325 =head2 get_indices
 326
 327 Returns all the index objects as an array or array reference.
 328
 329   my @indices = $table->get_indices;
 330
 331 =cut
 332
 333     my $self = shift;
 334
 335     if ( ref $self->{'indices'} ) {
 336         return wantarray
 337             ? @{ $self->{'indices'} }
 338             : $self->{'indices'};
 339     }
 340     else {
 341         $self->error('No indices');
 342         return wantarray ? () : undef;
 343     }
 344 }
 345
 346 # ----------------------------------------------------------------------
 347 sub get_field {
 348
 349 =pod
 350
 351 =head2 get_field
 352
 353 Returns a field by the name provided.
 354
 355   my $field = $table->get_field('foo');
 356
 357 =cut
 358
 359     my $self       = shift;
 360     my $field_name = shift or return $self->error('No field name');
 361     return $self->error( qq[Field "$field_name" does not exist] ) unless
 362         exists $self->{'fields'}{ $field_name };
 363     return $self->{'fields'}{ $field_name };
 364 }
 365
 366 # ----------------------------------------------------------------------
 367 sub get_fields {
 368
 369 =pod
 370
 371 =head2 get_fields
 372
 373 Returns all the field objects as an array or array reference.
 374
 375   my @fields = $table->get_fields;
 376
 377 =cut
 378
 379     my $self = shift;
 380     my @fields =
 381         map  { $_->[1] }
 382         sort { $a->[0] <=> $b->[0] }
 383         map  { [ $_->order, $_ ] }
 384         values %{ $self->{'fields'} || {} };
 385
 386     if ( @fields ) {
 387         return wantarray ? @fields : \@fields;
 388     }
 389     else {
 390         $self->error('No fields');
 391         return wantarray ? () : undef;
 392     }
 393 }
 394
 395 # ----------------------------------------------------------------------
 396 sub is_valid {
 397
 398 =pod
 399
 400 =head2 is_valid
 401
 402 Determine whether the view is valid or not.
 403
 404   my $ok = $view->is_valid;
 405
 406 =cut
 407
 408     my $self = shift;
 409     return $self->error('No name')   unless $self->name;
 410     return $self->error('No fields') unless $self->get_fields;
 411
 412     for my $object (
 413         $self->get_fields, $self->get_indices, $self->get_constraints
 414     ) {
 415         return $object->error unless $object->is_valid;
 416     }
 417
 418     return 1;
 419 }
 420
 421 # ----------------------------------------------------------------------
 422 sub name {
 423
 424 =pod
 425
 426 =head2 name
 427
 428 Get or set the table's name.
 429
 430 If provided an argument, checks the schema object for a table of
 431 that name and disallows the change if one exists.
 432
 433   my $table_name = $table->name('foo');
 434
 435 =cut
 436
 437     my $self = shift;
 438
 439     if ( my $arg = shift ) {
 440         if ( my $schema = $self->schema ) {
 441             return $self->error( qq[Can't use table name "$arg": table exists] )
 442                 if $schema->get_table( $arg );
 443         }
 444         $self->{'name'} = $arg;
 445     }
 446
 447     return $self->{'name'} || '';
 448 }
 449
 450 # ----------------------------------------------------------------------
 451 sub schema {
 452
 453 =pod
 454
 455 =head2 schema
 456
 457 Get or set the table's schema object.
 458
 459   my $schema = $table->schema;
 460
 461 =cut
 462
 463     my $self = shift;
 464     if ( my $arg = shift ) {
 465         return $self->error('Not a schema object') unless
 466             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
 467         $self->{'schema'} = $arg;
 468     }
 469
 470     return $self->{'schema'};
 471 }
 472
 473 # ----------------------------------------------------------------------
 474 sub primary_key {
 475
 476 =pod
 477
 478 =head2 options
 479
 480 Gets or sets the table's primary key(s).  Takes one or more field
 481 names (as a string, list or array[ref]) as an argument.  If the field
 482 names are present, it will create a new PK if none exists, or it will
 483 add to the fields of an existing PK (and will unique the field names).
 484 Returns the C<SQL::Translator::Schema::Constraint> object representing
 485 the primary key.
 486
 487 These are eqivalent:
 488
 489   $table->primary_key('id');
 490   $table->primary_key(['name']);
 491   $table->primary_key('id','name']);
 492   $table->primary_key(['id','name']);
 493   $table->primary_key('id,name');
 494   $table->primary_key(qw[ id name ]);
 495
 496   my $pk = $table->primary_key;
 497
 498 =cut
 499
 500     my $self   = shift;
 501     my $fields = parse_list_arg( @_ );
 502
 503     my $constraint;
 504     if ( @$fields ) {
 505         for my $f ( @$fields ) {
 506             return $self->error(qq[Invalid field "$f"]) unless
 507                 $self->get_field($f);
 508         }
 509
 510         my $has_pk;
 511         for my $c ( $self->get_constraints ) {
 512             if ( $c->type eq PRIMARY_KEY ) {
 513                 $has_pk = 1;
 514                 $c->fields( @{ $c->fields }, @$fields );
 515                 $constraint = $c;
 516             }
 517         }
 518
 519         unless ( $has_pk ) {
 520             $constraint = $self->add_constraint(
 521                 type   => PRIMARY_KEY,
 522                 fields => $fields,
 523             ) or return;
 524         }
 525     }
 526
 527     if ( $constraint ) {
 528         return $constraint;
 529     }
 530     else {
 531         for my $c ( $self->get_constraints ) {
 532             return $c if $c->type eq PRIMARY_KEY;
 533         }
 534     }
 535
 536     return;
 537 }
 538
 539 # ----------------------------------------------------------------------
 540 sub options {
 541
 542 =pod
 543
 544 =head2 options
 545
 546 Get or set the table's options (e.g., table types for MySQL).  Returns
 547 an array or array reference.
 548
 549   my @options = $table->options;
 550
 551 =cut
 552
 553     my $self    = shift;
 554     my $options = parse_list_arg( @_ );
 555
 556     push @{ $self->{'options'} }, @$options;
 557
 558     if ( ref $self->{'options'} ) {
 559         return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
 560     }
 561     else {
 562         return wantarray ? () : [];
 563     }
 564 }
 565
 566 # ----------------------------------------------------------------------
 567 sub order {
 568
 569 =pod
 570
 571 =head2 order
 572
 573 Get or set the table's order.
 574
 575   my $order = $table->order(3);
 576
 577 =cut
 578
 579     my ( $self, $arg ) = @_;
 580
 581     if ( defined $arg && $arg =~ /^\d+$/ ) {
 582         $self->{'order'} = $arg;
 583     }
 584
 585     return $self->{'order'} || 0;
 586 }
 587
 588 # ----------------------------------------------------------------------
 589 sub DESTROY {
 590     my $self = shift;
 591     undef $self->{'schema'}; # destroy cyclical reference
 592     undef $_ for @{ $self->{'constraints'} };
 593     undef $_ for @{ $self->{'indices'} };
 594     undef $_ for values %{ $self->{'fields'} };
 595 }
 596
 597 1;
 598
 599 # ----------------------------------------------------------------------
 600
 601 =pod
 602
 603 =head1 AUTHOR
 604
 605 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 606
 607 =cut