1 package SQL::Translator::Schema::Constraint;
7 SQL::Translator::Schema::Constraint - SQL::Translator constraint object
11 use SQL::Translator::Schema::Constraint;
12 my $constraint = SQL::Translator::Schema::Constraint->new(
20 C<SQL::Translator::Schema::Constraint> is the constraint object.
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);
33 SQL::Translator::Schema::Role::BuildArgs
34 SQL::Translator::Schema::Role::Extra
35 SQL::Translator::Schema::Role::Error
36 SQL::Translator::Schema::Role::Compare
39 our ( $TABLE_COUNT, $VIEW_COUNT );
41 our $VERSION = '1.59';
43 my %VALID_CONSTRAINT_TYPE = (
55 my $schema = SQL::Translator::Schema::Constraint->new(
56 table => $table, # table to which it belongs
57 type => 'foreign_key', # type of table constraint
58 name => 'fk_phone_id', # name of the constraint
59 fields => 'phone_id', # field in the referring table
60 reference_fields => 'phone_id', # referenced field
61 reference_table => 'phone', # referenced table
62 match_type => 'full', # how to match
63 on_delete => 'cascade', # what to do on deletes
64 on_update => '', # what to do on updates
69 # Override to remove empty arrays from args.
70 # t/14postgres-parser breaks without this.
71 around BUILDARGS => sub {
74 my $args = $self->$orig(@_);
76 foreach my $arg (keys %{$args}) {
77 delete $args->{$arg} if ref($args->{$arg}) eq "ARRAY" && !@{$args->{$arg}};
79 if (exists $args->{fields}) {
80 $args->{field_names} = delete $args->{fields};
87 Get or set whether the constraint is deferrable. If not defined,
88 then returns "1." The argument is evaluated by Perl for True or
89 False, so the following are eqivalent:
91 $deferrable = $field->deferrable(0);
92 $deferrable = $field->deferrable('');
93 $deferrable = $field->deferrable('0');
97 has deferrable => ( is => 'rw', coerce => sub { $_[0] ? 1 : 0 }, default => sub { 1 } );
101 Gets and set the expression used in a CHECK constraint.
103 my $expression = $constraint->expression('...');
107 has expression => ( is => 'rw', default => sub { '' } );
109 around expression => sub {
110 my ($orig, $self, $arg) = @_;
111 $self->$orig($arg || ());
120 Determine whether the constraint is valid or not.
122 my $ok = $constraint->is_valid;
127 my $type = $self->type or return $self->error('No type');
128 my $table = $self->table or return $self->error('No table');
129 my @fields = $self->fields or return $self->error('No fields');
130 my $table_name = $table->name or return $self->error('No table name');
132 for my $f ( @fields ) {
133 next if $table->get_field( $f );
135 "Constraint references non-existent field '$f' ",
136 "in table '$table_name'"
140 my $schema = $table->schema or return $self->error(
141 'Table ', $table->name, ' has no schema object'
144 if ( $type eq FOREIGN_KEY ) {
145 return $self->error('Only one field allowed for foreign key')
146 if scalar @fields > 1;
148 my $ref_table_name = $self->reference_table or
149 return $self->error('No reference table');
151 my $ref_table = $schema->get_table( $ref_table_name ) or
152 return $self->error("No table named '$ref_table_name' in schema");
154 my @ref_fields = $self->reference_fields or return;
156 return $self->error('Only one field allowed for foreign key reference')
157 if scalar @ref_fields > 1;
159 for my $ref_field ( @ref_fields ) {
160 next if $ref_table->get_field( $ref_field );
162 "Constraint from field(s) ".
163 join(', ', map {qq['$table_name.$_']} @fields).
164 " to non-existent field '$ref_table_name.$ref_field'"
168 elsif ( $type eq CHECK_C ) {
169 return $self->error('No expression for CHECK') unless
178 Gets and set the fields the constraint is on. Accepts a string, list or
179 arrayref; returns an array or array reference. Will unique the field
180 names and keep them in order by the first occurrence of a field name.
182 The fields are returned as Field objects if they exist or as plain
183 names if not. (If you just want the names and want to avoid the Field's overload
184 magic use L<field_names>).
186 Returns undef or an empty list if the constraint has no fields set.
188 $constraint->fields('id');
189 $constraint->fields('id', 'name');
190 $constraint->fields( 'id, name' );
191 $constraint->fields( [ 'id', 'name' ] );
192 $constraint->fields( qw[ id name ] );
194 my @fields = $constraint->fields;
200 my $table = $self->table;
201 my @tables = map { $table->get_field($_) || $_ } @{$self->field_names(@_) || []};
202 return wantarray ? @tables
209 Read-only method to return a list or array ref of the field names. Returns undef
210 or an empty list if the constraint has no fields set. Useful if you want to
211 avoid the overload magic of the Field objects returned by the fields method.
213 my @names = $constraint->field_names;
219 default => sub { [] },
220 coerce => sub { [uniq @{parse_list_arg($_[0])}] },
223 around field_names => sub {
226 my $fields = parse_list_arg( @_ );
227 $self->$orig($fields) if @$fields;
229 $fields = $self->$orig;
230 return wantarray ? @{$fields}
231 : @{$fields} ? $fields
237 Get or set the constraint's match_type. Only valid values are "full"
238 "partial" and "simple"
240 my $match_type = $constraint->match_type('FULL');
246 default => sub { '' },
247 coerce => sub { lc $_[0] },
250 throw("Invalid match type: $arg")
251 if $arg && !($arg eq 'full' || $arg eq 'partial' || $arg eq 'simple');
255 around match_type => \&ex2err;
259 Get or set the constraint's name.
261 my $name = $constraint->name('foo');
265 has name => ( is => 'rw', default => sub { '' } );
268 my ($orig, $self, $arg) = @_;
269 $self->$orig($arg || ());
274 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
275 Returns an array or array reference.
277 $constraint->options('NORELY');
278 my @options = $constraint->options;
282 has options => ( is => 'rw', coerce => \&parse_list_arg, default => sub { [] } );
284 around options => sub {
287 my $options = parse_list_arg( @_ );
289 push @{ $self->$orig }, @$options;
291 return wantarray ? @{ $self->$orig } : $self->$orig;
296 Get or set the constraint's "on delete" action.
298 my $action = $constraint->on_delete('cascade');
302 has on_delete => ( is => 'rw', default => sub { '' } );
304 around on_delete => sub {
305 my ($orig, $self, $arg) = @_;
306 $self->$orig($arg || ());
311 Get or set the constraint's "on update" action.
313 my $action = $constraint->on_update('no action');
317 has on_update => ( is => 'rw', default => sub { '' } );
319 around on_update => sub {
320 my ($orig, $self, $arg) = @_;
321 $self->$orig($arg || ());
324 =head2 reference_fields
326 Gets and set the fields in the referred table. Accepts a string, list or
327 arrayref; returns an array or array reference.
329 $constraint->reference_fields('id');
330 $constraint->reference_fields('id', 'name');
331 $constraint->reference_fields( 'id, name' );
332 $constraint->reference_fields( [ 'id', 'name' ] );
333 $constraint->reference_fields( qw[ id name ] );
335 my @reference_fields = $constraint->reference_fields;
339 has reference_fields => (
341 coerce => sub { [uniq @{parse_list_arg($_[0])}] },
346 around reference_fields => sub {
349 my $fields = parse_list_arg( @_ );
350 $self->$orig($fields) if @$fields;
352 $fields = ex2err($orig, $self) or return;
353 return wantarray ? @{$fields} : $fields
356 sub _build_reference_fields {
359 my $table = $self->table or throw('No table');
360 my $schema = $table->schema or throw('No schema');
361 if ( my $ref_table_name = $self->reference_table ) {
362 my $ref_table = $schema->get_table( $ref_table_name ) or
363 throw("Can't find table '$ref_table_name'");
365 if ( my $constraint = $ref_table->primary_key ) {
366 return [ $constraint->fields ];
370 'No reference fields defined and cannot find primary key in ',
371 "reference table '$ref_table_name'"
377 =head2 reference_table
379 Get or set the table referred to by the constraint.
381 my $reference_table = $constraint->reference_table('foo');
385 has reference_table => ( is => 'rw', default => sub { '' } );
389 Get or set the constraint's table object.
391 my $table = $field->table;
395 has table => ( is => 'rw', isa => schema_obj('Table') );
397 around table => \&ex2err;
401 Get or set the constraint's type.
403 my $type = $constraint->type( PRIMARY_KEY );
409 default => sub { '' },
411 throw("Invalid constraint type: $_[0]")
412 if $_[0] && !$VALID_CONSTRAINT_TYPE{ $_[0] };
414 coerce => sub { (my $t = $_[0]) =~ s/_/ /g; uc $t },
417 around type => \&ex2err;
421 Determines if this constraint is the same as another
423 my $isIdentical = $constraint1->equals( $constraint2 );
427 around equals => sub {
431 my $case_insensitive = shift;
432 my $ignore_constraint_names = shift;
434 return 0 unless $self->$orig($other);
435 return 0 unless $self->type eq $other->type;
436 unless ($ignore_constraint_names) {
437 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
439 return 0 unless $self->deferrable eq $other->deferrable;
440 #return 0 unless $self->is_valid eq $other->is_valid;
441 return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
442 : $self->table->name eq $other->table->name;
443 return 0 unless $self->expression eq $other->expression;
445 # Check fields, regardless of order
446 my %otherFields = (); # create a hash of the other fields
447 foreach my $otherField ($other->fields) {
448 $otherField = uc($otherField) if $case_insensitive;
449 $otherFields{$otherField} = 1;
451 foreach my $selfField ($self->fields) { # check for self fields in hash
452 $selfField = uc($selfField) if $case_insensitive;
453 return 0 unless $otherFields{$selfField};
454 delete $otherFields{$selfField};
456 # Check all other fields were accounted for
457 return 0 unless keys %otherFields == 0;
459 # Check reference fields, regardless of order
460 my %otherRefFields = (); # create a hash of the other reference fields
461 foreach my $otherRefField ($other->reference_fields) {
462 $otherRefField = uc($otherRefField) if $case_insensitive;
463 $otherRefFields{$otherRefField} = 1;
465 foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash
466 $selfRefField = uc($selfRefField) if $case_insensitive;
467 return 0 unless $otherRefFields{$selfRefField};
468 delete $otherRefFields{$selfRefField};
470 # Check all other reference fields were accounted for
471 return 0 unless keys %otherRefFields == 0;
473 return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table;
474 return 0 unless $self->match_type eq $other->match_type;
475 return 0 unless $self->on_delete eq $other->on_delete;
476 return 0 unless $self->on_update eq $other->on_update;
477 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
478 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
484 undef $self->{'table'}; # destroy cyclical reference
487 # Must come after all 'has' declarations
488 around new => \&ex2err;
496 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.