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