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);
32 extends 'SQL::Translator::Schema::Object';
34 our $VERSION = '1.59';
36 my %VALID_CONSTRAINT_TYPE = (
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
62 # Override to remove empty arrays from args.
63 # t/14postgres-parser breaks without this.
64 around BUILDARGS => sub {
67 my $args = $self->$orig(@_);
69 foreach my $arg (keys %{$args}) {
70 delete $args->{$arg} if ref($args->{$arg}) eq "ARRAY" && !@{$args->{$arg}};
72 if (exists $args->{fields}) {
73 $args->{field_names} = delete $args->{fields};
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:
84 $deferrable = $field->deferrable(0);
85 $deferrable = $field->deferrable('');
86 $deferrable = $field->deferrable('0');
90 has deferrable => ( is => 'rw', coerce => sub { $_[0] ? 1 : 0 }, default => sub { 1 } );
94 Gets and set the expression used in a CHECK constraint.
96 my $expression = $constraint->expression('...');
100 has expression => ( is => 'rw', default => sub { '' } );
102 around expression => sub {
103 my ($orig, $self, $arg) = @_;
104 $self->$orig($arg || ());
113 Determine whether the constraint is valid or not.
115 my $ok = $constraint->is_valid;
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');
125 for my $f ( @fields ) {
126 next if $table->get_field( $f );
128 "Constraint references non-existent field '$f' ",
129 "in table '$table_name'"
133 my $schema = $table->schema or return $self->error(
134 'Table ', $table->name, ' has no schema object'
137 if ( $type eq FOREIGN_KEY ) {
138 return $self->error('Only one field allowed for foreign key')
139 if scalar @fields > 1;
141 my $ref_table_name = $self->reference_table or
142 return $self->error('No reference table');
144 my $ref_table = $schema->get_table( $ref_table_name ) or
145 return $self->error("No table named '$ref_table_name' in schema");
147 my @ref_fields = $self->reference_fields or return;
149 return $self->error('Only one field allowed for foreign key reference')
150 if scalar @ref_fields > 1;
152 for my $ref_field ( @ref_fields ) {
153 next if $ref_table->get_field( $ref_field );
155 "Constraint from field(s) ".
156 join(', ', map {qq['$table_name.$_']} @fields).
157 " to non-existent field '$ref_table_name.$ref_field'"
161 elsif ( $type eq CHECK_C ) {
162 return $self->error('No expression for CHECK') unless
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.
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>).
179 Returns undef or an empty list if the constraint has no fields set.
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 ] );
187 my @fields = $constraint->fields;
193 my $table = $self->table;
194 my @tables = map { $table->get_field($_) || $_ } @{$self->field_names(@_) || []};
195 return wantarray ? @tables
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.
206 my @names = $constraint->field_names;
212 default => sub { [] },
213 coerce => sub { [uniq @{parse_list_arg($_[0])}] },
216 around field_names => sub {
219 my $fields = parse_list_arg( @_ );
220 $self->$orig($fields) if @$fields;
222 $fields = $self->$orig;
223 return wantarray ? @{$fields}
224 : @{$fields} ? $fields
230 Get or set the constraint's match_type. Only valid values are "full"
231 "partial" and "simple"
233 my $match_type = $constraint->match_type('FULL');
239 default => sub { '' },
240 coerce => sub { lc $_[0] },
243 throw("Invalid match type: $arg")
244 if $arg && !($arg eq 'full' || $arg eq 'partial' || $arg eq 'simple');
248 around match_type => \&ex2err;
252 Get or set the constraint's name.
254 my $name = $constraint->name('foo');
258 has name => ( is => 'rw', default => sub { '' } );
261 my ($orig, $self, $arg) = @_;
262 $self->$orig($arg || ());
267 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
268 Returns an array or array reference.
270 $constraint->options('NORELY');
271 my @options = $constraint->options;
275 has options => ( is => 'rw', coerce => \&parse_list_arg, default => sub { [] } );
277 around options => sub {
280 my $options = parse_list_arg( @_ );
282 push @{ $self->$orig }, @$options;
284 return wantarray ? @{ $self->$orig } : $self->$orig;
289 Get or set the constraint's "on delete" action.
291 my $action = $constraint->on_delete('cascade');
295 has on_delete => ( is => 'rw', default => sub { '' } );
297 around on_delete => sub {
298 my ($orig, $self, $arg) = @_;
299 $self->$orig($arg || ());
304 Get or set the constraint's "on update" action.
306 my $action = $constraint->on_update('no action');
310 has on_update => ( is => 'rw', default => sub { '' } );
312 around on_update => sub {
313 my ($orig, $self, $arg) = @_;
314 $self->$orig($arg || ());
317 =head2 reference_fields
319 Gets and set the fields in the referred table. Accepts a string, list or
320 arrayref; returns an array or array reference.
322 $constraint->reference_fields('id');
323 $constraint->reference_fields('id', 'name');
324 $constraint->reference_fields( 'id, name' );
325 $constraint->reference_fields( [ 'id', 'name' ] );
326 $constraint->reference_fields( qw[ id name ] );
328 my @reference_fields = $constraint->reference_fields;
332 has reference_fields => (
334 coerce => sub { [uniq @{parse_list_arg($_[0])}] },
339 around reference_fields => sub {
342 my $fields = parse_list_arg( @_ );
343 $self->$orig($fields) if @$fields;
345 $fields = ex2err($orig, $self) or return;
346 return wantarray ? @{$fields} : $fields
349 sub _build_reference_fields {
352 my $table = $self->table or throw('No table');
353 my $schema = $table->schema or throw('No schema');
354 if ( my $ref_table_name = $self->reference_table ) {
355 my $ref_table = $schema->get_table( $ref_table_name ) or
356 throw("Can't find table '$ref_table_name'");
358 if ( my $constraint = $ref_table->primary_key ) {
359 return [ $constraint->fields ];
363 'No reference fields defined and cannot find primary key in ',
364 "reference table '$ref_table_name'"
370 =head2 reference_table
372 Get or set the table referred to by the constraint.
374 my $reference_table = $constraint->reference_table('foo');
378 has reference_table => ( is => 'rw', default => sub { '' } );
382 Get or set the constraint's table object.
384 my $table = $field->table;
388 has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
390 around table => \&ex2err;
394 Get or set the constraint's type.
396 my $type = $constraint->type( PRIMARY_KEY );
402 default => sub { '' },
404 throw("Invalid constraint type: $_[0]")
405 if $_[0] && !$VALID_CONSTRAINT_TYPE{ $_[0] };
407 coerce => sub { (my $t = $_[0]) =~ s/_/ /g; uc $t },
410 around type => \&ex2err;
414 Determines if this constraint is the same as another
416 my $isIdentical = $constraint1->equals( $constraint2 );
420 around equals => sub {
424 my $case_insensitive = shift;
425 my $ignore_constraint_names = shift;
427 return 0 unless $self->$orig($other);
428 return 0 unless $self->type eq $other->type;
429 unless ($ignore_constraint_names) {
430 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
432 return 0 unless $self->deferrable eq $other->deferrable;
433 #return 0 unless $self->is_valid eq $other->is_valid;
434 return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
435 : $self->table->name eq $other->table->name;
436 return 0 unless $self->expression eq $other->expression;
438 # Check fields, regardless of order
439 my %otherFields = (); # create a hash of the other fields
440 foreach my $otherField ($other->fields) {
441 $otherField = uc($otherField) if $case_insensitive;
442 $otherFields{$otherField} = 1;
444 foreach my $selfField ($self->fields) { # check for self fields in hash
445 $selfField = uc($selfField) if $case_insensitive;
446 return 0 unless $otherFields{$selfField};
447 delete $otherFields{$selfField};
449 # Check all other fields were accounted for
450 return 0 unless keys %otherFields == 0;
452 # Check reference fields, regardless of order
453 my %otherRefFields = (); # create a hash of the other reference fields
454 foreach my $otherRefField ($other->reference_fields) {
455 $otherRefField = uc($otherRefField) if $case_insensitive;
456 $otherRefFields{$otherRefField} = 1;
458 foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash
459 $selfRefField = uc($selfRefField) if $case_insensitive;
460 return 0 unless $otherRefFields{$selfRefField};
461 delete $otherRefFields{$selfRefField};
463 # Check all other reference fields were accounted for
464 return 0 unless keys %otherRefFields == 0;
466 return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table;
467 return 0 unless $self->match_type eq $other->match_type;
468 return 0 unless $self->on_delete eq $other->on_delete;
469 return 0 unless $self->on_update eq $other->on_update;
470 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
471 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
475 # Must come after all 'has' declarations
476 around new => \&ex2err;
484 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.