lib/SQL/Translator/Schema/Constraint.pm

   1 package SQL::Translator::Schema::Constraint;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Constraint.pm,v 1.12 2004-03-29 10:19:08 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::Constraint - SQL::Translator constraint object
  28
  29 =head1 SYNOPSIS
  30
  31   use SQL::Translator::Schema::Constraint;
  32   my $constraint = SQL::Translator::Schema::Constraint->new(
  33       name   => 'foo',
  34       fields => [ id ],
  35       type   => PRIMARY_KEY,
  36   );
  37
  38 =head1 DESCRIPTION
  39
  40 C<SQL::Translator::Schema::Constraint> is the constraint object.
  41
  42 =head1 METHODS
  43
  44 =cut
  45
  46 use strict;
  47 use Class::Base;
  48 use SQL::Translator::Schema::Constants;
  49 use SQL::Translator::Utils 'parse_list_arg';
  50
  51 use base 'Class::Base';
  52 use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
  53
  54 $VERSION = sprintf "%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/;
  55
  56 my %VALID_CONSTRAINT_TYPE = (
  57     PRIMARY_KEY, 1,
  58     UNIQUE,      1,
  59     CHECK_C,     1,
  60     FOREIGN_KEY, 1,
  61     NOT_NULL,    1,
  62 );
  63
  64 # ----------------------------------------------------------------------
  65 sub init {
  66
  67 =pod
  68
  69 =head2 new
  70
  71 Object constructor.
  72
  73   my $schema           =  SQL::Translator::Schema::Constraint->new(
  74       table            => $table,        # table to which it belongs
  75       type             => 'foreign_key', # type of table constraint
  76       name             => 'fk_phone_id', # name of the constraint
  77       fields           => 'phone_id',    # field in the referring table
  78       reference_fields => 'phone_id',    # referenced field
  79       reference_table  => 'phone',       # referenced table
  80       match_type       => 'full',        # how to match
  81       on_delete        => 'cascade',     # what to do on deletes
  82       on_update        => '',            # what to do on updates
  83   );
  84
  85 =cut
  86
  87     my ( $self, $config ) = @_;
  88     my @fields = qw[
  89         table name type fields reference_fields reference_table
  90         match_type on_delete on_update expression
  91     ];
  92
  93     for my $arg ( @fields ) {
  94         next unless $config->{ $arg };
  95         next if ref $config->{ $arg } eq 'ARRAY' && ! @{ $config->{ $arg } };
  96         defined $self->$arg( $config->{ $arg } ) or return;
  97     }
  98
  99     return $self;
 100 }
 101
 102 # ----------------------------------------------------------------------
 103 sub deferrable {
 104
 105 =pod
 106
 107 =head2 deferrable
 108
 109 Get or set whether the constraint is deferrable.  If not defined,
 110 then returns "1."  The argument is evaluated by Perl for True or
 111 False, so the following are eqivalent:
 112
 113   $deferrable = $field->deferrable(0);
 114   $deferrable = $field->deferrable('');
 115   $deferrable = $field->deferrable('0');
 116
 117 =cut
 118
 119     my ( $self, $arg ) = @_;
 120
 121     if ( defined $arg ) {
 122         $self->{'deferrable'} = $arg ? 1 : 0;
 123     }
 124
 125     return defined $self->{'deferrable'} ? $self->{'deferrable'} : 1;
 126 }
 127
 128 # ----------------------------------------------------------------------
 129 sub expression {
 130
 131 =pod
 132
 133 =head2 expression
 134
 135 Gets and set the expression used in a CHECK constraint.
 136
 137   my $expression = $constraint->expression('...');
 138
 139 =cut
 140
 141     my $self = shift;
 142
 143     if ( my $arg = shift ) {
 144         # check arg here?
 145         $self->{'expression'} = $arg;
 146     }
 147
 148     return $self->{'expression'} || '';
 149 }
 150
 151 # ----------------------------------------------------------------------
 152 sub is_valid {
 153
 154 =pod
 155
 156 =head2 is_valid
 157
 158 Determine whether the constraint is valid or not.
 159
 160   my $ok = $constraint->is_valid;
 161
 162 =cut
 163
 164     my $self       = shift;
 165     my $type       = $self->type   or return $self->error('No type');
 166     my $table      = $self->table  or return $self->error('No table');
 167     my @fields     = $self->fields or return $self->error('No fields');
 168     my $table_name = $table->name  or return $self->error('No table name');
 169
 170     for my $f ( @fields ) {
 171         next if $table->get_field( $f );
 172         return $self->error(
 173             "Constraint references non-existent field '$f' ",
 174             "in table '$table_name'"
 175         );
 176     }
 177
 178     my $schema = $table->schema or return $self->error(
 179         'Table ', $table->name, ' has no schema object'
 180     );
 181
 182     if ( $type eq FOREIGN_KEY ) {
 183         return $self->error('Only one field allowed for foreign key')
 184             if scalar @fields > 1;
 185
 186         my $ref_table_name  = $self->reference_table or
 187             return $self->error('No reference table');
 188
 189         my $ref_table = $schema->get_table( $ref_table_name ) or
 190             return $self->error("No table named '$ref_table_name' in schema");
 191
 192         my @ref_fields = $self->reference_fields or return;
 193
 194         return $self->error('Only one field allowed for foreign key reference')
 195             if scalar @ref_fields > 1;
 196
 197         for my $ref_field ( @ref_fields ) {
 198             next if $ref_table->get_field( $ref_field );
 199             return $self->error(
 200                 "Constraint from field(s) ",
 201                 join(', ', map {qq['$table_name.$_']} @fields),
 202                 " to non-existent field '$ref_table_name.$ref_field'"
 203             );
 204         }
 205     }
 206     elsif ( $type eq CHECK_C ) {
 207         return $self->error('No expression for CHECK') unless
 208             $self->expression;
 209     }
 210
 211     return 1;
 212 }
 213
 214 # ----------------------------------------------------------------------
 215 sub fields {
 216
 217 =pod
 218
 219 =head2 fields
 220
 221 Gets and set the fields the constraint is on.  Accepts a string, list or
 222 arrayref; returns an array or array reference.  Will unique the field
 223 names and keep them in order by the first occurrence of a field name.
 224
 225 The fields are returned as Field objects if they exist or as plain
 226 names if not. (If you just want the names and want to avoid the Field's overload
 227 magic use L<field_names>).
 228
 229 Returns undef or an empty list if the constraint has no fields set.
 230
 231   $constraint->fields('id');
 232   $constraint->fields('id', 'name');
 233   $constraint->fields( 'id, name' );
 234   $constraint->fields( [ 'id', 'name' ] );
 235   $constraint->fields( qw[ id name ] );
 236
 237   my @fields = $constraint->fields;
 238
 239 =cut
 240
 241     my $self   = shift;
 242     my $fields = parse_list_arg( @_ );
 243
 244     if ( @$fields ) {
 245         my ( %unique, @unique );
 246         for my $f ( @$fields ) {
 247             next if $unique{ $f };
 248             $unique{ $f } = 1;
 249             push @unique, $f;
 250         }
 251
 252         $self->{'fields'} = \@unique;
 253     }
 254
 255     if ( @{ $self->{'fields'} || [] } ) {
 256         # We have to return fields that don't exist on the table as names in
 257         # case those fields havn't been created yet.
 258         my @ret = map {
 259             $self->table->get_field($_) || $_ } @{ $self->{'fields'} };
 260         return wantarray ? @ret : \@ret;
 261     }
 262     else {
 263         return wantarray ? () : undef;
 264     }
 265 }
 266
 267 sub field_names {
 268
 269 =head2 field_names
 270
 271 Read-only method to return a list or array ref of the field names. Returns undef
 272 or an empty list if the constraint has no fields set. Usefull if you want to
 273 avoid the overload magic of the Field objects returned by the fields method.
 274
 275   my @names = $constraint->field_names;
 276
 277 =cut
 278
 279     my $self = shift;
 280     return wantarray ? @{ $self->{'fields'} } : $self->{'fields'};
 281 }
 282
 283 # ----------------------------------------------------------------------
 284 sub match_type {
 285
 286 =pod
 287
 288 =head2 match_type
 289
 290 Get or set the constraint's match_type.  Only valid values are "full"
 291 or "partial."
 292
 293   my $match_type = $constraint->match_type('FULL');
 294
 295 =cut
 296
 297     my $self = shift;
 298
 299     if ( my $arg = lc shift ) {
 300         return $self->error("Invalid match type: $arg")
 301             unless $arg eq 'full' || $arg eq 'partial';
 302         $self->{'match_type'} = $arg;
 303     }
 304
 305     return $self->{'match_type'} || '';
 306 }
 307
 308 # ----------------------------------------------------------------------
 309 sub name {
 310
 311 =pod
 312
 313 =head2 name
 314
 315 Get or set the constraint's name.
 316
 317   my $name = $constraint->name('foo');
 318
 319 =cut
 320
 321     my $self = shift;
 322     my $arg  = shift || '';
 323     $self->{'name'} = $arg if $arg;
 324     return $self->{'name'} || '';
 325 }
 326
 327 # ----------------------------------------------------------------------
 328 sub options {
 329
 330 =pod
 331
 332 =head2 options
 333
 334 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
 335 Returns an array or array reference.
 336
 337   $constraint->options('NORELY');
 338   my @options = $constraint->options;
 339
 340 =cut
 341
 342     my $self    = shift;
 343     my $options = parse_list_arg( @_ );
 344
 345     push @{ $self->{'options'} }, @$options;
 346
 347     if ( ref $self->{'options'} ) {
 348         return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
 349     }
 350     else {
 351         return wantarray ? () : [];
 352     }
 353 }
 354
 355
 356 # ----------------------------------------------------------------------
 357 sub on_delete {
 358
 359 =pod
 360
 361 =head2 on_delete
 362
 363 Get or set the constraint's "on delete" action.
 364
 365   my $action = $constraint->on_delete('cascade');
 366
 367 =cut
 368
 369     my $self = shift;
 370
 371     if ( my $arg = shift ) {
 372         # validate $arg?
 373         $self->{'on_delete'} = $arg;
 374     }
 375
 376     return $self->{'on_delete'} || '';
 377 }
 378
 379 # ----------------------------------------------------------------------
 380 sub on_update {
 381
 382 =pod
 383
 384 =head2 on_update
 385
 386 Get or set the constraint's "on update" action.
 387
 388   my $action = $constraint->on_update('no action');
 389
 390 =cut
 391
 392     my $self = shift;
 393
 394     if ( my $arg = shift ) {
 395         # validate $arg?
 396         $self->{'on_update'} = $arg;
 397     }
 398
 399     return $self->{'on_update'} || '';
 400 }
 401
 402 # ----------------------------------------------------------------------
 403 sub reference_fields {
 404
 405 =pod
 406
 407 =head2 reference_fields
 408
 409 Gets and set the fields in the referred table.  Accepts a string, list or
 410 arrayref; returns an array or array reference.
 411
 412   $constraint->reference_fields('id');
 413   $constraint->reference_fields('id', 'name');
 414   $constraint->reference_fields( 'id, name' );
 415   $constraint->reference_fields( [ 'id', 'name' ] );
 416   $constraint->reference_fields( qw[ id name ] );
 417
 418   my @reference_fields = $constraint->reference_fields;
 419
 420 =cut
 421
 422     my $self   = shift;
 423     my $fields = parse_list_arg( @_ );
 424
 425     if ( @$fields ) {
 426         $self->{'reference_fields'} = $fields;
 427     }
 428
 429     # Nothing set so try and derive it from the other constraint data
 430     unless ( ref $self->{'reference_fields'} ) {
 431         my $table   = $self->table   or return $self->error('No table');
 432         my $schema  = $table->schema or return $self->error('No schema');
 433         if ( my $ref_table_name = $self->reference_table ) {
 434             my $ref_table  = $schema->get_table( $ref_table_name ) or
 435                 return $self->error("Can't find table '$ref_table_name'");
 436
 437             if ( my $constraint = $ref_table->primary_key ) {
 438                 $self->{'reference_fields'} = [ $constraint->fields ];
 439             }
 440             else {
 441                 $self->error(
 442                  'No reference fields defined and cannot find primary key in ',
 443                  "reference table '$ref_table_name'"
 444                 );
 445             }
 446         }
 447         # No ref table so we are not that sort of constraint, hence no ref
 448         # fields. So we let the return below return an empty list.
 449     }
 450
 451     if ( ref $self->{'reference_fields'} ) {
 452         return wantarray
 453             ?  @{ $self->{'reference_fields'} }
 454             :     $self->{'reference_fields'};
 455     }
 456     else {
 457         return wantarray ? () : [];
 458     }
 459 }
 460
 461 # ----------------------------------------------------------------------
 462 sub reference_table {
 463
 464 =pod
 465
 466 =head2 reference_table
 467
 468 Get or set the table referred to by the constraint.
 469
 470   my $reference_table = $constraint->reference_table('foo');
 471
 472 =cut
 473
 474     my $self = shift;
 475     $self->{'reference_table'} = shift if @_;
 476     return $self->{'reference_table'} || '';
 477 }
 478
 479 # ----------------------------------------------------------------------
 480 sub table {
 481
 482 =pod
 483
 484 =head2 table
 485
 486 Get or set the constraint's table object.
 487
 488   my $table = $field->table;
 489
 490 =cut
 491
 492     my $self = shift;
 493     if ( my $arg = shift ) {
 494         return $self->error('Not a table object') unless
 495             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
 496         $self->{'table'} = $arg;
 497     }
 498
 499     return $self->{'table'};
 500 }
 501
 502 # ----------------------------------------------------------------------
 503 sub type {
 504
 505 =pod
 506
 507 =head2 type
 508
 509 Get or set the constraint's type.
 510
 511   my $type = $constraint->type( PRIMARY_KEY );
 512
 513 =cut
 514
 515     my $self = shift;
 516
 517     if ( my $type = uc shift ) {
 518         $type =~ s/_/ /g;
 519         return $self->error("Invalid constraint type: $type")
 520             unless $VALID_CONSTRAINT_TYPE{ $type };
 521         $self->{'type'} = $type;
 522     }
 523
 524     return $self->{'type'} || '';
 525 }
 526 # ----------------------------------------------------------------------
 527 sub DESTROY {
 528     my $self = shift;
 529     undef $self->{'table'}; # destroy cyclical reference
 530 }
 531
 532 1;
 533
 534 # ----------------------------------------------------------------------
 535
 536 =pod
 537
 538 =head1 AUTHOR
 539
 540 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 541
 542 =cut