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 enum);
  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 equivalent:
  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 @fields = map { $table->get_field($_) || $_ } @{$self->field_names(@_) || []};
 200     return wantarray ? @fields
 201         : @fields ? \@fields
 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 => enum([qw(full partial simple)], {
 231         msg => "Invalid match type: %s", allow_false => 1,
 232     }),
 233 );
 234
 235 around match_type => \&ex2err;
 236
 237 =head2 name
 238
 239 Get or set the constraint's name.
 240
 241   my $name = $constraint->name('foo');
 242
 243 =cut
 244
 245 has name => ( is => 'rw', default => quote_sub(q{ '' }) );
 246
 247 around name => sub {
 248     my ($orig, $self, $arg) = @_;
 249     $self->$orig($arg || ());
 250 };
 251
 252 =head2 options
 253
 254 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
 255 Returns an array or array reference.
 256
 257   $constraint->options('NORELY');
 258   my @options = $constraint->options;
 259
 260 =cut
 261
 262 with ListAttr options => ();
 263
 264 =head2 on_delete
 265
 266 Get or set the constraint's "on delete" action.
 267
 268   my $action = $constraint->on_delete('cascade');
 269
 270 =cut
 271
 272 has on_delete => ( is => 'rw', default => quote_sub(q{ '' }) );
 273
 274 around on_delete => sub {
 275     my ($orig, $self, $arg) = @_;
 276     $self->$orig($arg || ());
 277 };
 278
 279 =head2 on_update
 280
 281 Get or set the constraint's "on update" action.
 282
 283   my $action = $constraint->on_update('no action');
 284
 285 =cut
 286
 287 has on_update => ( is => 'rw', default => quote_sub(q{ '' }) );
 288
 289 around on_update => sub {
 290     my ($orig, $self, $arg) = @_;
 291     $self->$orig($arg || ());
 292 };
 293
 294 =head2 reference_fields
 295
 296 Gets and set the fields in the referred table.  Accepts a string, list or
 297 arrayref; returns an array or array reference.
 298
 299   $constraint->reference_fields('id');
 300   $constraint->reference_fields('id', 'name');
 301   $constraint->reference_fields( 'id, name' );
 302   $constraint->reference_fields( [ 'id', 'name' ] );
 303   $constraint->reference_fields( qw[ id name ] );
 304
 305   my @reference_fields = $constraint->reference_fields;
 306
 307 =cut
 308
 309 with ListAttr reference_fields => (
 310     may_throw => 1,
 311     builder => 1,
 312     lazy => 1,
 313 );
 314
 315 sub _build_reference_fields {
 316     my ($self) = @_;
 317
 318     my $table   = $self->table   or throw('No table');
 319     my $schema  = $table->schema or throw('No schema');
 320     if ( my $ref_table_name = $self->reference_table ) {
 321         my $ref_table  = $schema->get_table( $ref_table_name ) or
 322             throw("Can't find table '$ref_table_name'");
 323
 324         if ( my $constraint = $ref_table->primary_key ) {
 325             return [ $constraint->fields ];
 326         }
 327         else {
 328             throw(
 329                 'No reference fields defined and cannot find primary key in ',
 330                 "reference table '$ref_table_name'"
 331             );
 332         }
 333     }
 334 }
 335
 336 =head2 reference_table
 337
 338 Get or set the table referred to by the constraint.
 339
 340   my $reference_table = $constraint->reference_table('foo');
 341
 342 =cut
 343
 344 has reference_table => ( is => 'rw', default => quote_sub(q{ '' }) );
 345
 346 =head2 table
 347
 348 Get or set the constraint's table object.
 349
 350   my $table = $field->table;
 351
 352 =cut
 353
 354 has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
 355
 356 around table => \&ex2err;
 357
 358 =head2 type
 359
 360 Get or set the constraint's type.
 361
 362   my $type = $constraint->type( PRIMARY_KEY );
 363
 364 =cut
 365
 366 has type => (
 367     is => 'rw',
 368     default => quote_sub(q{ '' }),
 369     coerce => quote_sub(q{ (my $t = $_[0]) =~ s/_/ /g; uc $t }),
 370     isa => enum([keys %VALID_CONSTRAINT_TYPE], {
 371         msg => "Invalid constraint type: %s", allow_false => 1,
 372     }),
 373 );
 374
 375 around type => \&ex2err;
 376
 377 =head2 equals
 378
 379 Determines if this constraint is the same as another
 380
 381   my $isIdentical = $constraint1->equals( $constraint2 );
 382
 383 =cut
 384
 385 around equals => sub {
 386     my $orig = shift;
 387     my $self = shift;
 388     my $other = shift;
 389     my $case_insensitive = shift;
 390     my $ignore_constraint_names = shift;
 391
 392     return 0 unless $self->$orig($other);
 393     return 0 unless $self->type eq $other->type;
 394     unless ($ignore_constraint_names) {
 395         return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
 396     }
 397     return 0 unless $self->deferrable eq $other->deferrable;
 398     #return 0 unless $self->is_valid eq $other->is_valid;
 399     return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
 400       : $self->table->name eq $other->table->name;
 401     return 0 unless $self->expression eq $other->expression;
 402
 403     # Check fields, regardless of order
 404     my %otherFields = ();  # create a hash of the other fields
 405     foreach my $otherField ($other->fields) {
 406       $otherField = uc($otherField) if $case_insensitive;
 407       $otherFields{$otherField} = 1;
 408     }
 409     foreach my $selfField ($self->fields) { # check for self fields in hash
 410       $selfField = uc($selfField) if $case_insensitive;
 411       return 0 unless $otherFields{$selfField};
 412       delete $otherFields{$selfField};
 413     }
 414     # Check all other fields were accounted for
 415     return 0 unless keys %otherFields == 0;
 416
 417     # Check reference fields, regardless of order
 418     my %otherRefFields = ();  # create a hash of the other reference fields
 419     foreach my $otherRefField ($other->reference_fields) {
 420       $otherRefField = uc($otherRefField) if $case_insensitive;
 421       $otherRefFields{$otherRefField} = 1;
 422     }
 423     foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash
 424       $selfRefField = uc($selfRefField) if $case_insensitive;
 425       return 0 unless $otherRefFields{$selfRefField};
 426       delete $otherRefFields{$selfRefField};
 427     }
 428     # Check all other reference fields were accounted for
 429     return 0 unless keys %otherRefFields == 0;
 430
 431     return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table;
 432     return 0 unless $self->match_type eq $other->match_type;
 433     return 0 unless $self->on_delete eq $other->on_delete;
 434     return 0 unless $self->on_update eq $other->on_update;
 435     return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
 436     return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
 437     return 1;
 438 };
 439
 440 # Must come after all 'has' declarations
 441 around new => \&ex2err;
 442
 443 1;
 444
 445 =pod
 446
 447 =head1 AUTHOR
 448
 449 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 450
 451 =cut