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