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