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