lib/SQL/Translator/Schema/Table.pm

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