lib/SQL/Translator/Schema/Constraint.pm

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