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