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