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