lib/SQL/Translator/Schema/Constraint.pm

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