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, $arg ) = @_;
 295
 296     if ( $arg ) {
 297         $arg = lc $arg;
 298         return $self->error("Invalid match type: $arg")
 299             unless $arg eq 'full' || $arg eq 'partial';
 300         $self->{'match_type'} = $arg;
 301     }
 302
 303     return $self->{'match_type'} || '';
 304 }
 305
 306 # ----------------------------------------------------------------------
 307 sub name {
 308
 309 =pod
 310
 311 =head2 name
 312
 313 Get or set the constraint's name.
 314
 315   my $name = $constraint->name('foo');
 316
 317 =cut
 318
 319     my $self = shift;
 320     my $arg  = shift || '';
 321     $self->{'name'} = $arg if $arg;
 322     return $self->{'name'} || '';
 323 }
 324
 325 # ----------------------------------------------------------------------
 326 sub options {
 327
 328 =pod
 329
 330 =head2 options
 331
 332 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
 333 Returns an array or array reference.
 334
 335   $constraint->options('NORELY');
 336   my @options = $constraint->options;
 337
 338 =cut
 339
 340     my $self    = shift;
 341     my $options = parse_list_arg( @_ );
 342
 343     push @{ $self->{'options'} }, @$options;
 344
 345     if ( ref $self->{'options'} ) {
 346         return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
 347     }
 348     else {
 349         return wantarray ? () : [];
 350     }
 351 }
 352
 353
 354 # ----------------------------------------------------------------------
 355 sub on_delete {
 356
 357 =pod
 358
 359 =head2 on_delete
 360
 361 Get or set the constraint's "on delete" action.
 362
 363   my $action = $constraint->on_delete('cascade');
 364
 365 =cut
 366
 367     my $self = shift;
 368
 369     if ( my $arg = shift ) {
 370         # validate $arg?
 371         $self->{'on_delete'} = $arg;
 372     }
 373
 374     return $self->{'on_delete'} || '';
 375 }
 376
 377 # ----------------------------------------------------------------------
 378 sub on_update {
 379
 380 =pod
 381
 382 =head2 on_update
 383
 384 Get or set the constraint's "on update" action.
 385
 386   my $action = $constraint->on_update('no action');
 387
 388 =cut
 389
 390     my $self = shift;
 391
 392     if ( my $arg = shift ) {
 393         # validate $arg?
 394         $self->{'on_update'} = $arg;
 395     }
 396
 397     return $self->{'on_update'} || '';
 398 }
 399
 400 # ----------------------------------------------------------------------
 401 sub reference_fields {
 402
 403 =pod
 404
 405 =head2 reference_fields
 406
 407 Gets and set the fields in the referred table.  Accepts a string, list or
 408 arrayref; returns an array or array reference.
 409
 410   $constraint->reference_fields('id');
 411   $constraint->reference_fields('id', 'name');
 412   $constraint->reference_fields( 'id, name' );
 413   $constraint->reference_fields( [ 'id', 'name' ] );
 414   $constraint->reference_fields( qw[ id name ] );
 415
 416   my @reference_fields = $constraint->reference_fields;
 417
 418 =cut
 419
 420     my $self   = shift;
 421     my $fields = parse_list_arg( @_ );
 422
 423     if ( @$fields ) {
 424         $self->{'reference_fields'} = $fields;
 425     }
 426
 427     # Nothing set so try and derive it from the other constraint data
 428     unless ( ref $self->{'reference_fields'} ) {
 429         my $table   = $self->table   or return $self->error('No table');
 430         my $schema  = $table->schema or return $self->error('No schema');
 431         if ( my $ref_table_name = $self->reference_table ) {
 432             my $ref_table  = $schema->get_table( $ref_table_name ) or
 433                 return $self->error("Can't find table '$ref_table_name'");
 434
 435             if ( my $constraint = $ref_table->primary_key ) {
 436                 $self->{'reference_fields'} = [ $constraint->fields ];
 437             }
 438             else {
 439                 $self->error(
 440                  'No reference fields defined and cannot find primary key in ',
 441                  "reference table '$ref_table_name'"
 442                 );
 443             }
 444         }
 445         # No ref table so we are not that sort of constraint, hence no ref
 446         # fields. So we let the return below return an empty list.
 447     }
 448
 449     if ( ref $self->{'reference_fields'} ) {
 450         return wantarray
 451             ?  @{ $self->{'reference_fields'} }
 452             :     $self->{'reference_fields'};
 453     }
 454     else {
 455         return wantarray ? () : [];
 456     }
 457 }
 458
 459 # ----------------------------------------------------------------------
 460 sub reference_table {
 461
 462 =pod
 463
 464 =head2 reference_table
 465
 466 Get or set the table referred to by the constraint.
 467
 468   my $reference_table = $constraint->reference_table('foo');
 469
 470 =cut
 471
 472     my $self = shift;
 473     $self->{'reference_table'} = shift if @_;
 474     return $self->{'reference_table'} || '';
 475 }
 476
 477 # ----------------------------------------------------------------------
 478 sub table {
 479
 480 =pod
 481
 482 =head2 table
 483
 484 Get or set the constraint's table object.
 485
 486   my $table = $field->table;
 487
 488 =cut
 489
 490     my $self = shift;
 491     if ( my $arg = shift ) {
 492         return $self->error('Not a table object') unless
 493             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
 494         $self->{'table'} = $arg;
 495     }
 496
 497     return $self->{'table'};
 498 }
 499
 500 # ----------------------------------------------------------------------
 501 sub type {
 502
 503 =pod
 504
 505 =head2 type
 506
 507 Get or set the constraint's type.
 508
 509   my $type = $constraint->type( PRIMARY_KEY );
 510
 511 =cut
 512
 513     my ( $self, $type ) = @_;
 514
 515     if ( $type ) {
 516         $type = uc $type;
 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 Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 607
 608 =cut