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