lib/SQL/Translator/Schema/Constraint.pm

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