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 1.000003;
  27 use SQL::Translator::Schema::Constants;
  28 use SQL::Translator::Utils qw(ex2err throw);
  29 use SQL::Translator::Role::ListAttr;
  30 use SQL::Translator::Types qw(schema_obj);
  31 use Sub::Quote qw(quote_sub);
  32
  33 extends 'SQL::Translator::Schema::Object';
  34
  35 our $VERSION = '1.59';
  36
  37 my %VALID_CONSTRAINT_TYPE = (
  38     PRIMARY_KEY, 1,
  39     UNIQUE,      1,
  40     CHECK_C,     1,
  41     FOREIGN_KEY, 1,
  42     NOT_NULL,    1,
  43 );
  44
  45 =head2 new
  46
  47 Object constructor.
  48
  49   my $schema           =  SQL::Translator::Schema::Constraint->new(
  50       table            => $table,        # table to which it belongs
  51       type             => 'foreign_key', # type of table constraint
  52       name             => 'fk_phone_id', # name of the constraint
  53       fields           => 'phone_id',    # field in the referring table
  54       reference_fields => 'phone_id',    # referenced field
  55       reference_table  => 'phone',       # referenced table
  56       match_type       => 'full',        # how to match
  57       on_delete        => 'cascade',     # what to do on deletes
  58       on_update        => '',            # what to do on updates
  59   );
  60
  61 =cut
  62
  63 # Override to remove empty arrays from args.
  64 # t/14postgres-parser breaks without this.
  65 around BUILDARGS => sub {
  66     my $orig = shift;
  67     my $self = shift;
  68     my $args = $self->$orig(@_);
  69
  70     foreach my $arg (keys %{$args}) {
  71         delete $args->{$arg} if ref($args->{$arg}) eq "ARRAY" && !@{$args->{$arg}};
  72     }
  73     if (exists $args->{fields}) {
  74         $args->{field_names} = delete $args->{fields};
  75     }
  76     return $args;
  77 };
  78
  79 =head2 deferrable
  80
  81 Get or set whether the constraint is deferrable.  If not defined,
  82 then returns "1."  The argument is evaluated by Perl for True or
  83 False, so the following are eqivalent:
  84
  85   $deferrable = $field->deferrable(0);
  86   $deferrable = $field->deferrable('');
  87   $deferrable = $field->deferrable('0');
  88
  89 =cut
  90
  91 has deferrable => (
  92     is => 'rw',
  93     coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
  94     default => quote_sub(q{ 1 }),
  95 );
  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 => quote_sub(q{ '' }) );
 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 with ListAttr field_names => ( uniq => 1, undef_if_empty => 1 );
 216
 217 =head2 match_type
 218
 219 Get or set the constraint's match_type.  Only valid values are "full"
 220 "partial" and "simple"
 221
 222   my $match_type = $constraint->match_type('FULL');
 223
 224 =cut
 225
 226 has match_type => (
 227     is => 'rw',
 228     default => quote_sub(q{ '' }),
 229     coerce => quote_sub(q{ lc $_[0] }),
 230     isa => sub {
 231         my $arg = $_[0];
 232         throw("Invalid match type: $arg")
 233             if $arg && !($arg eq 'full' || $arg eq 'partial' || $arg eq 'simple');
 234     },
 235 );
 236
 237 around match_type => \&ex2err;
 238
 239 =head2 name
 240
 241 Get or set the constraint's name.
 242
 243   my $name = $constraint->name('foo');
 244
 245 =cut
 246
 247 has name => ( is => 'rw', default => quote_sub(q{ '' }) );
 248
 249 around name => sub {
 250     my ($orig, $self, $arg) = @_;
 251     $self->$orig($arg || ());
 252 };
 253
 254 =head2 options
 255
 256 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
 257 Returns an array or array reference.
 258
 259   $constraint->options('NORELY');
 260   my @options = $constraint->options;
 261
 262 =cut
 263
 264 with ListAttr options => ();
 265
 266 =head2 on_delete
 267
 268 Get or set the constraint's "on delete" action.
 269
 270   my $action = $constraint->on_delete('cascade');
 271
 272 =cut
 273
 274 has on_delete => ( is => 'rw', default => quote_sub(q{ '' }) );
 275
 276 around on_delete => sub {
 277     my ($orig, $self, $arg) = @_;
 278     $self->$orig($arg || ());
 279 };
 280
 281 =head2 on_update
 282
 283 Get or set the constraint's "on update" action.
 284
 285   my $action = $constraint->on_update('no action');
 286
 287 =cut
 288
 289 has on_update => ( is => 'rw', default => quote_sub(q{ '' }) );
 290
 291 around on_update => sub {
 292     my ($orig, $self, $arg) = @_;
 293     $self->$orig($arg || ());
 294 };
 295
 296 =head2 reference_fields
 297
 298 Gets and set the fields in the referred table.  Accepts a string, list or
 299 arrayref; returns an array or array reference.
 300
 301   $constraint->reference_fields('id');
 302   $constraint->reference_fields('id', 'name');
 303   $constraint->reference_fields( 'id, name' );
 304   $constraint->reference_fields( [ 'id', 'name' ] );
 305   $constraint->reference_fields( qw[ id name ] );
 306
 307   my @reference_fields = $constraint->reference_fields;
 308
 309 =cut
 310
 311 with ListAttr reference_fields => (
 312     may_throw => 1,
 313     builder => 1,
 314     lazy => 1,
 315 );
 316
 317 sub _build_reference_fields {
 318     my ($self) = @_;
 319
 320     my $table   = $self->table   or throw('No table');
 321     my $schema  = $table->schema or throw('No schema');
 322     if ( my $ref_table_name = $self->reference_table ) {
 323         my $ref_table  = $schema->get_table( $ref_table_name ) or
 324             throw("Can't find table '$ref_table_name'");
 325
 326         if ( my $constraint = $ref_table->primary_key ) {
 327             return [ $constraint->fields ];
 328         }
 329         else {
 330             throw(
 331                 'No reference fields defined and cannot find primary key in ',
 332                 "reference table '$ref_table_name'"
 333             );
 334         }
 335     }
 336 }
 337
 338 =head2 reference_table
 339
 340 Get or set the table referred to by the constraint.
 341
 342   my $reference_table = $constraint->reference_table('foo');
 343
 344 =cut
 345
 346 has reference_table => ( is => 'rw', default => quote_sub(q{ '' }) );
 347
 348 =head2 table
 349
 350 Get or set the constraint's table object.
 351
 352   my $table = $field->table;
 353
 354 =cut
 355
 356 has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
 357
 358 around table => \&ex2err;
 359
 360 =head2 type
 361
 362 Get or set the constraint's type.
 363
 364   my $type = $constraint->type( PRIMARY_KEY );
 365
 366 =cut
 367
 368 has type => (
 369     is => 'rw',
 370     default => quote_sub(q{ '' }),
 371     isa => sub {
 372         throw("Invalid constraint type: $_[0]")
 373             if $_[0] && !$VALID_CONSTRAINT_TYPE{ $_[0] };
 374     },
 375     coerce => quote_sub(q{ (my $t = $_[0]) =~ s/_/ /g; uc $t }),
 376 );
 377
 378 around type => \&ex2err;
 379
 380 =head2 equals
 381
 382 Determines if this constraint is the same as another
 383
 384   my $isIdentical = $constraint1->equals( $constraint2 );
 385
 386 =cut
 387
 388 around equals => sub {
 389     my $orig = shift;
 390     my $self = shift;
 391     my $other = shift;
 392     my $case_insensitive = shift;
 393     my $ignore_constraint_names = shift;
 394
 395     return 0 unless $self->$orig($other);
 396     return 0 unless $self->type eq $other->type;
 397     unless ($ignore_constraint_names) {
 398         return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
 399     }
 400     return 0 unless $self->deferrable eq $other->deferrable;
 401     #return 0 unless $self->is_valid eq $other->is_valid;
 402     return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
 403       : $self->table->name eq $other->table->name;
 404     return 0 unless $self->expression eq $other->expression;
 405
 406     # Check fields, regardless of order
 407     my %otherFields = ();  # create a hash of the other fields
 408     foreach my $otherField ($other->fields) {
 409       $otherField = uc($otherField) if $case_insensitive;
 410       $otherFields{$otherField} = 1;
 411     }
 412     foreach my $selfField ($self->fields) { # check for self fields in hash
 413       $selfField = uc($selfField) if $case_insensitive;
 414       return 0 unless $otherFields{$selfField};
 415       delete $otherFields{$selfField};
 416     }
 417     # Check all other fields were accounted for
 418     return 0 unless keys %otherFields == 0;
 419
 420     # Check reference fields, regardless of order
 421     my %otherRefFields = ();  # create a hash of the other reference fields
 422     foreach my $otherRefField ($other->reference_fields) {
 423       $otherRefField = uc($otherRefField) if $case_insensitive;
 424       $otherRefFields{$otherRefField} = 1;
 425     }
 426     foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash
 427       $selfRefField = uc($selfRefField) if $case_insensitive;
 428       return 0 unless $otherRefFields{$selfRefField};
 429       delete $otherRefFields{$selfRefField};
 430     }
 431     # Check all other reference fields were accounted for
 432     return 0 unless keys %otherRefFields == 0;
 433
 434     return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table;
 435     return 0 unless $self->match_type eq $other->match_type;
 436     return 0 unless $self->on_delete eq $other->on_delete;
 437     return 0 unless $self->on_update eq $other->on_update;
 438     return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
 439     return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
 440     return 1;
 441 };
 442
 443 # Must come after all 'has' declarations
 444 around new => \&ex2err;
 445
 446 1;
 447
 448 =pod
 449
 450 =head1 AUTHOR
 451
 452 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 453
 454 =cut