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::Extra
34 SQL::Translator::Schema::Role::Error
35 SQL::Translator::Schema::Role::Compare
38 our ( $TABLE_COUNT, $VIEW_COUNT );
40 our $VERSION = '1.59';
42 my %VALID_CONSTRAINT_TYPE = (
54 my $schema = SQL::Translator::Schema::Constraint->new(
55 table => $table, # table to which it belongs
56 type => 'foreign_key', # type of table constraint
57 name => 'fk_phone_id', # name of the constraint
58 fields => 'phone_id', # field in the referring table
59 reference_fields => 'phone_id', # referenced field
60 reference_table => 'phone', # referenced table
61 match_type => 'full', # how to match
62 on_delete => 'cascade', # what to do on deletes
63 on_update => '', # what to do on updates
68 # Override to remove empty arrays from args.
69 # t/14postgres-parser breaks without this.
70 around BUILDARGS => sub {
73 my $args = $self->$orig(@_);
75 foreach my $arg (keys %{$args}) {
76 delete $args->{$arg} if !defined($args->{$arg}) || (ref($args->{$arg}) eq "ARRAY" && !@{$args->{$arg}});
78 if (exists $args->{fields}) {
79 $args->{field_names} = delete $args->{fields};
86 Get or set whether the constraint is deferrable. If not defined,
87 then returns "1." The argument is evaluated by Perl for True or
88 False, so the following are eqivalent:
90 $deferrable = $field->deferrable(0);
91 $deferrable = $field->deferrable('');
92 $deferrable = $field->deferrable('0');
96 has deferrable => ( is => 'rw', coerce => sub { $_[0] ? 1 : 0 }, default => sub { 1 } );
100 Gets and set the expression used in a CHECK constraint.
102 my $expression = $constraint->expression('...');
106 has expression => ( is => 'rw', default => sub { '' } );
108 around expression => sub {
109 my ($orig, $self, $arg) = @_;
110 $self->$orig($arg || ());
119 Determine whether the constraint is valid or not.
121 my $ok = $constraint->is_valid;
126 my $type = $self->type or return $self->error('No type');
127 my $table = $self->table or return $self->error('No table');
128 my @fields = $self->fields or return $self->error('No fields');
129 my $table_name = $table->name or return $self->error('No table name');
131 for my $f ( @fields ) {
132 next if $table->get_field( $f );
134 "Constraint references non-existent field '$f' ",
135 "in table '$table_name'"
139 my $schema = $table->schema or return $self->error(
140 'Table ', $table->name, ' has no schema object'
143 if ( $type eq FOREIGN_KEY ) {
144 return $self->error('Only one field allowed for foreign key')
145 if scalar @fields > 1;
147 my $ref_table_name = $self->reference_table or
148 return $self->error('No reference table');
150 my $ref_table = $schema->get_table( $ref_table_name ) or
151 return $self->error("No table named '$ref_table_name' in schema");
153 my @ref_fields = $self->reference_fields or return;
155 return $self->error('Only one field allowed for foreign key reference')
156 if scalar @ref_fields > 1;
158 for my $ref_field ( @ref_fields ) {
159 next if $ref_table->get_field( $ref_field );
161 "Constraint from field(s) ".
162 join(', ', map {qq['$table_name.$_']} @fields).
163 " to non-existent field '$ref_table_name.$ref_field'"
167 elsif ( $type eq CHECK_C ) {
168 return $self->error('No expression for CHECK') unless
177 Gets and set the fields the constraint is on. Accepts a string, list or
178 arrayref; returns an array or array reference. Will unique the field
179 names and keep them in order by the first occurrence of a field name.
181 The fields are returned as Field objects if they exist or as plain
182 names if not. (If you just want the names and want to avoid the Field's overload
183 magic use L<field_names>).
185 Returns undef or an empty list if the constraint has no fields set.
187 $constraint->fields('id');
188 $constraint->fields('id', 'name');
189 $constraint->fields( 'id, name' );
190 $constraint->fields( [ 'id', 'name' ] );
191 $constraint->fields( qw[ id name ] );
193 my @fields = $constraint->fields;
199 my $table = $self->table;
200 my @tables = map { $table->get_field($_) || $_ } @{$self->field_names(@_) || []};
201 return wantarray ? @tables
208 Read-only method to return a list or array ref of the field names. Returns undef
209 or an empty list if the constraint has no fields set. Useful if you want to
210 avoid the overload magic of the Field objects returned by the fields method.
212 my @names = $constraint->field_names;
218 default => sub { [] },
219 coerce => sub { [uniq @{parse_list_arg($_[0])}] },
222 around field_names => sub {
225 my $fields = parse_list_arg( @_ );
226 $self->$orig($fields) if @$fields;
228 $fields = $self->$orig;
229 return wantarray ? @{$fields}
230 : @{$fields} ? $fields
236 Get or set the constraint's match_type. Only valid values are "full"
237 "partial" and "simple"
239 my $match_type = $constraint->match_type('FULL');
245 default => sub { '' },
246 coerce => sub { lc $_[0] },
249 throw("Invalid match type: $arg")
250 if $arg && !($arg eq 'full' || $arg eq 'partial' || $arg eq 'simple');
254 around match_type => \&ex2err;
258 Get or set the constraint's name.
260 my $name = $constraint->name('foo');
264 has name => ( is => 'rw', default => sub { '' } );
267 my ($orig, $self, $arg) = @_;
268 $self->$orig($arg || ());
273 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
274 Returns an array or array reference.
276 $constraint->options('NORELY');
277 my @options = $constraint->options;
281 has options => ( is => 'rw', coerce => \&parse_list_arg, default => sub { [] } );
283 around options => sub {
286 my $options = parse_list_arg( @_ );
288 push @{ $self->$orig }, @$options;
290 return wantarray ? @{ $self->$orig } : $self->$orig;
295 Get or set the constraint's "on delete" action.
297 my $action = $constraint->on_delete('cascade');
301 has on_delete => ( is => 'rw', default => sub { '' } );
303 around on_delete => sub {
304 my ($orig, $self, $arg) = @_;
305 $self->$orig($arg || ());
310 Get or set the constraint's "on update" action.
312 my $action = $constraint->on_update('no action');
316 has on_update => ( is => 'rw', default => sub { '' } );
318 around on_update => sub {
319 my ($orig, $self, $arg) = @_;
320 $self->$orig($arg || ());
323 =head2 reference_fields
325 Gets and set the fields in the referred table. Accepts a string, list or
326 arrayref; returns an array or array reference.
328 $constraint->reference_fields('id');
329 $constraint->reference_fields('id', 'name');
330 $constraint->reference_fields( 'id, name' );
331 $constraint->reference_fields( [ 'id', 'name' ] );
332 $constraint->reference_fields( qw[ id name ] );
334 my @reference_fields = $constraint->reference_fields;
338 has reference_fields => (
340 coerce => sub { [uniq @{parse_list_arg($_[0])}] },
345 around reference_fields => sub {
348 my $fields = parse_list_arg( @_ );
349 $self->$orig($fields) if @$fields;
351 $fields = ex2err($orig, $self) or return;
352 return wantarray ? @{$fields} : $fields
355 sub _build_reference_fields {
358 my $table = $self->table or throw('No table');
359 my $schema = $table->schema or throw('No schema');
360 if ( my $ref_table_name = $self->reference_table ) {
361 my $ref_table = $schema->get_table( $ref_table_name ) or
362 throw("Can't find table '$ref_table_name'");
364 if ( my $constraint = $ref_table->primary_key ) {
365 return [ $constraint->fields ];
369 'No reference fields defined and cannot find primary key in ',
370 "reference table '$ref_table_name'"
376 =head2 reference_table
378 Get or set the table referred to by the constraint.
380 my $reference_table = $constraint->reference_table('foo');
384 has reference_table => ( is => 'rw', default => sub { '' } );
388 Get or set the constraint's table object.
390 my $table = $field->table;
394 has table => ( is => 'rw', isa => schema_obj('Table') );
396 around table => \&ex2err;
400 Get or set the constraint's type.
402 my $type = $constraint->type( PRIMARY_KEY );
408 default => sub { '' },
410 throw("Invalid constraint type: $_[0]")
411 if $_[0] && !$VALID_CONSTRAINT_TYPE{ $_[0] };
413 coerce => sub { (my $t = $_[0]) =~ s/_/ /g; uc $t },
416 around type => \&ex2err;
420 Determines if this constraint is the same as another
422 my $isIdentical = $constraint1->equals( $constraint2 );
426 around equals => sub {
430 my $case_insensitive = shift;
431 my $ignore_constraint_names = shift;
433 return 0 unless $self->$orig($other);
434 return 0 unless $self->type eq $other->type;
435 unless ($ignore_constraint_names) {
436 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
438 return 0 unless $self->deferrable eq $other->deferrable;
439 #return 0 unless $self->is_valid eq $other->is_valid;
440 return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
441 : $self->table->name eq $other->table->name;
442 return 0 unless $self->expression eq $other->expression;
444 # Check fields, regardless of order
445 my %otherFields = (); # create a hash of the other fields
446 foreach my $otherField ($other->fields) {
447 $otherField = uc($otherField) if $case_insensitive;
448 $otherFields{$otherField} = 1;
450 foreach my $selfField ($self->fields) { # check for self fields in hash
451 $selfField = uc($selfField) if $case_insensitive;
452 return 0 unless $otherFields{$selfField};
453 delete $otherFields{$selfField};
455 # Check all other fields were accounted for
456 return 0 unless keys %otherFields == 0;
458 # Check reference fields, regardless of order
459 my %otherRefFields = (); # create a hash of the other reference fields
460 foreach my $otherRefField ($other->reference_fields) {
461 $otherRefField = uc($otherRefField) if $case_insensitive;
462 $otherRefFields{$otherRefField} = 1;
464 foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash
465 $selfRefField = uc($selfRefField) if $case_insensitive;
466 return 0 unless $otherRefFields{$selfRefField};
467 delete $otherRefFields{$selfRefField};
469 # Check all other reference fields were accounted for
470 return 0 unless keys %otherRefFields == 0;
472 return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table;
473 return 0 unless $self->match_type eq $other->match_type;
474 return 0 unless $self->on_delete eq $other->on_delete;
475 return 0 unless $self->on_update eq $other->on_update;
476 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
477 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
483 undef $self->{'table'}; # destroy cyclical reference
486 # Must come after all 'has' declarations
487 around new => \&ex2err;
495 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.