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