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 $VERSION = '1.59';
41 my %VALID_CONSTRAINT_TYPE = (
53 my $schema = SQL::Translator::Schema::Constraint->new(
54 table => $table, # table to which it belongs
55 type => 'foreign_key', # type of table constraint
56 name => 'fk_phone_id', # name of the constraint
57 fields => 'phone_id', # field in the referring table
58 reference_fields => 'phone_id', # referenced field
59 reference_table => 'phone', # referenced table
60 match_type => 'full', # how to match
61 on_delete => 'cascade', # what to do on deletes
62 on_update => '', # what to do on updates
67 # Override to remove empty arrays from args.
68 # t/14postgres-parser breaks without this.
69 around BUILDARGS => sub {
72 my $args = $self->$orig(@_);
74 foreach my $arg (keys %{$args}) {
75 delete $args->{$arg} if ref($args->{$arg}) eq "ARRAY" && !@{$args->{$arg}};
77 if (exists $args->{fields}) {
78 $args->{field_names} = delete $args->{fields};
85 Get or set whether the constraint is deferrable. If not defined,
86 then returns "1." The argument is evaluated by Perl for True or
87 False, so the following are eqivalent:
89 $deferrable = $field->deferrable(0);
90 $deferrable = $field->deferrable('');
91 $deferrable = $field->deferrable('0');
95 has deferrable => ( is => 'rw', coerce => sub { $_[0] ? 1 : 0 }, default => sub { 1 } );
99 Gets and set the expression used in a CHECK constraint.
101 my $expression = $constraint->expression('...');
105 has expression => ( is => 'rw', default => sub { '' } );
107 around expression => sub {
108 my ($orig, $self, $arg) = @_;
109 $self->$orig($arg || ());
118 Determine whether the constraint is valid or not.
120 my $ok = $constraint->is_valid;
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');
130 for my $f ( @fields ) {
131 next if $table->get_field( $f );
133 "Constraint references non-existent field '$f' ",
134 "in table '$table_name'"
138 my $schema = $table->schema or return $self->error(
139 'Table ', $table->name, ' has no schema object'
142 if ( $type eq FOREIGN_KEY ) {
143 return $self->error('Only one field allowed for foreign key')
144 if scalar @fields > 1;
146 my $ref_table_name = $self->reference_table or
147 return $self->error('No reference table');
149 my $ref_table = $schema->get_table( $ref_table_name ) or
150 return $self->error("No table named '$ref_table_name' in schema");
152 my @ref_fields = $self->reference_fields or return;
154 return $self->error('Only one field allowed for foreign key reference')
155 if scalar @ref_fields > 1;
157 for my $ref_field ( @ref_fields ) {
158 next if $ref_table->get_field( $ref_field );
160 "Constraint from field(s) ".
161 join(', ', map {qq['$table_name.$_']} @fields).
162 " to non-existent field '$ref_table_name.$ref_field'"
166 elsif ( $type eq CHECK_C ) {
167 return $self->error('No expression for CHECK') unless
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.
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>).
184 Returns undef or an empty list if the constraint has no fields set.
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 ] );
192 my @fields = $constraint->fields;
198 my $table = $self->table;
199 my @tables = map { $table->get_field($_) || $_ } @{$self->field_names(@_) || []};
200 return wantarray ? @tables
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.
211 my @names = $constraint->field_names;
217 default => sub { [] },
218 coerce => sub { [uniq @{parse_list_arg($_[0])}] },
221 around field_names => sub {
224 my $fields = parse_list_arg( @_ );
225 $self->$orig($fields) if @$fields;
227 $fields = $self->$orig;
228 return wantarray ? @{$fields}
229 : @{$fields} ? $fields
235 Get or set the constraint's match_type. Only valid values are "full"
236 "partial" and "simple"
238 my $match_type = $constraint->match_type('FULL');
244 default => sub { '' },
245 coerce => sub { lc $_[0] },
248 throw("Invalid match type: $arg")
249 if $arg && !($arg eq 'full' || $arg eq 'partial' || $arg eq 'simple');
253 around match_type => \&ex2err;
257 Get or set the constraint's name.
259 my $name = $constraint->name('foo');
263 has name => ( is => 'rw', default => sub { '' } );
266 my ($orig, $self, $arg) = @_;
267 $self->$orig($arg || ());
272 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
273 Returns an array or array reference.
275 $constraint->options('NORELY');
276 my @options = $constraint->options;
280 has options => ( is => 'rw', coerce => \&parse_list_arg, default => sub { [] } );
282 around options => sub {
285 my $options = parse_list_arg( @_ );
287 push @{ $self->$orig }, @$options;
289 return wantarray ? @{ $self->$orig } : $self->$orig;
294 Get or set the constraint's "on delete" action.
296 my $action = $constraint->on_delete('cascade');
300 has on_delete => ( is => 'rw', default => sub { '' } );
302 around on_delete => sub {
303 my ($orig, $self, $arg) = @_;
304 $self->$orig($arg || ());
309 Get or set the constraint's "on update" action.
311 my $action = $constraint->on_update('no action');
315 has on_update => ( is => 'rw', default => sub { '' } );
317 around on_update => sub {
318 my ($orig, $self, $arg) = @_;
319 $self->$orig($arg || ());
322 =head2 reference_fields
324 Gets and set the fields in the referred table. Accepts a string, list or
325 arrayref; returns an array or array reference.
327 $constraint->reference_fields('id');
328 $constraint->reference_fields('id', 'name');
329 $constraint->reference_fields( 'id, name' );
330 $constraint->reference_fields( [ 'id', 'name' ] );
331 $constraint->reference_fields( qw[ id name ] );
333 my @reference_fields = $constraint->reference_fields;
337 has reference_fields => (
339 coerce => sub { [uniq @{parse_list_arg($_[0])}] },
344 around reference_fields => sub {
347 my $fields = parse_list_arg( @_ );
348 $self->$orig($fields) if @$fields;
350 $fields = ex2err($orig, $self) or return;
351 return wantarray ? @{$fields} : $fields
354 sub _build_reference_fields {
357 my $table = $self->table or throw('No table');
358 my $schema = $table->schema or throw('No schema');
359 if ( my $ref_table_name = $self->reference_table ) {
360 my $ref_table = $schema->get_table( $ref_table_name ) or
361 throw("Can't find table '$ref_table_name'");
363 if ( my $constraint = $ref_table->primary_key ) {
364 return [ $constraint->fields ];
368 'No reference fields defined and cannot find primary key in ',
369 "reference table '$ref_table_name'"
375 =head2 reference_table
377 Get or set the table referred to by the constraint.
379 my $reference_table = $constraint->reference_table('foo');
383 has reference_table => ( is => 'rw', default => sub { '' } );
387 Get or set the constraint's table object.
389 my $table = $field->table;
393 has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
395 around table => \&ex2err;
399 Get or set the constraint's type.
401 my $type = $constraint->type( PRIMARY_KEY );
407 default => sub { '' },
409 throw("Invalid constraint type: $_[0]")
410 if $_[0] && !$VALID_CONSTRAINT_TYPE{ $_[0] };
412 coerce => sub { (my $t = $_[0]) =~ s/_/ /g; uc $t },
415 around type => \&ex2err;
419 Determines if this constraint is the same as another
421 my $isIdentical = $constraint1->equals( $constraint2 );
425 around equals => sub {
429 my $case_insensitive = shift;
430 my $ignore_constraint_names = shift;
432 return 0 unless $self->$orig($other);
433 return 0 unless $self->type eq $other->type;
434 unless ($ignore_constraint_names) {
435 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
437 return 0 unless $self->deferrable eq $other->deferrable;
438 #return 0 unless $self->is_valid eq $other->is_valid;
439 return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
440 : $self->table->name eq $other->table->name;
441 return 0 unless $self->expression eq $other->expression;
443 # Check fields, regardless of order
444 my %otherFields = (); # create a hash of the other fields
445 foreach my $otherField ($other->fields) {
446 $otherField = uc($otherField) if $case_insensitive;
447 $otherFields{$otherField} = 1;
449 foreach my $selfField ($self->fields) { # check for self fields in hash
450 $selfField = uc($selfField) if $case_insensitive;
451 return 0 unless $otherFields{$selfField};
452 delete $otherFields{$selfField};
454 # Check all other fields were accounted for
455 return 0 unless keys %otherFields == 0;
457 # Check reference fields, regardless of order
458 my %otherRefFields = (); # create a hash of the other reference fields
459 foreach my $otherRefField ($other->reference_fields) {
460 $otherRefField = uc($otherRefField) if $case_insensitive;
461 $otherRefFields{$otherRefField} = 1;
463 foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash
464 $selfRefField = uc($selfRefField) if $case_insensitive;
465 return 0 unless $otherRefFields{$selfRefField};
466 delete $otherRefFields{$selfRefField};
468 # Check all other reference fields were accounted for
469 return 0 unless keys %otherRefFields == 0;
471 return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table;
472 return 0 unless $self->match_type eq $other->match_type;
473 return 0 unless $self->on_delete eq $other->on_delete;
474 return 0 unless $self->on_update eq $other->on_update;
475 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
476 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
480 # Must come after all 'has' declarations
481 around new => \&ex2err;
489 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.