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(ex2err throw);
29 use SQL::Translator::Role::ListAttr;
30 use SQL::Translator::Types qw(schema_obj);
31 use Sub::Quote qw(quote_sub);
33 extends 'SQL::Translator::Schema::Object';
35 our $VERSION = '1.59';
37 my %VALID_CONSTRAINT_TYPE = (
49 my $schema = SQL::Translator::Schema::Constraint->new(
50 table => $table, # table to which it belongs
51 type => 'foreign_key', # type of table constraint
52 name => 'fk_phone_id', # name of the constraint
53 fields => 'phone_id', # field in the referring table
54 reference_fields => 'phone_id', # referenced field
55 reference_table => 'phone', # referenced table
56 match_type => 'full', # how to match
57 on_delete => 'cascade', # what to do on deletes
58 on_update => '', # what to do on updates
63 # Override to remove empty arrays from args.
64 # t/14postgres-parser breaks without this.
65 around BUILDARGS => sub {
68 my $args = $self->$orig(@_);
70 foreach my $arg (keys %{$args}) {
71 delete $args->{$arg} if ref($args->{$arg}) eq "ARRAY" && !@{$args->{$arg}};
73 if (exists $args->{fields}) {
74 $args->{field_names} = delete $args->{fields};
81 Get or set whether the constraint is deferrable. If not defined,
82 then returns "1." The argument is evaluated by Perl for True or
83 False, so the following are eqivalent:
85 $deferrable = $field->deferrable(0);
86 $deferrable = $field->deferrable('');
87 $deferrable = $field->deferrable('0');
91 has deferrable => ( is => 'rw', coerce => quote_sub(q{ $_[0] ? 1 : 0 }), default => quote_sub(q{ 1 }) );
95 Gets and set the expression used in a CHECK constraint.
97 my $expression = $constraint->expression('...');
101 has expression => ( is => 'rw', default => quote_sub(q{ '' }) );
103 around expression => sub {
104 my ($orig, $self, $arg) = @_;
105 $self->$orig($arg || ());
114 Determine whether the constraint is valid or not.
116 my $ok = $constraint->is_valid;
121 my $type = $self->type or return $self->error('No type');
122 my $table = $self->table or return $self->error('No table');
123 my @fields = $self->fields or return $self->error('No fields');
124 my $table_name = $table->name or return $self->error('No table name');
126 for my $f ( @fields ) {
127 next if $table->get_field( $f );
129 "Constraint references non-existent field '$f' ",
130 "in table '$table_name'"
134 my $schema = $table->schema or return $self->error(
135 'Table ', $table->name, ' has no schema object'
138 if ( $type eq FOREIGN_KEY ) {
139 return $self->error('Only one field allowed for foreign key')
140 if scalar @fields > 1;
142 my $ref_table_name = $self->reference_table or
143 return $self->error('No reference table');
145 my $ref_table = $schema->get_table( $ref_table_name ) or
146 return $self->error("No table named '$ref_table_name' in schema");
148 my @ref_fields = $self->reference_fields or return;
150 return $self->error('Only one field allowed for foreign key reference')
151 if scalar @ref_fields > 1;
153 for my $ref_field ( @ref_fields ) {
154 next if $ref_table->get_field( $ref_field );
156 "Constraint from field(s) ".
157 join(', ', map {qq['$table_name.$_']} @fields).
158 " to non-existent field '$ref_table_name.$ref_field'"
162 elsif ( $type eq CHECK_C ) {
163 return $self->error('No expression for CHECK') unless
172 Gets and set the fields the constraint is on. Accepts a string, list or
173 arrayref; returns an array or array reference. Will unique the field
174 names and keep them in order by the first occurrence of a field name.
176 The fields are returned as Field objects if they exist or as plain
177 names if not. (If you just want the names and want to avoid the Field's overload
178 magic use L<field_names>).
180 Returns undef or an empty list if the constraint has no fields set.
182 $constraint->fields('id');
183 $constraint->fields('id', 'name');
184 $constraint->fields( 'id, name' );
185 $constraint->fields( [ 'id', 'name' ] );
186 $constraint->fields( qw[ id name ] );
188 my @fields = $constraint->fields;
194 my $table = $self->table;
195 my @tables = map { $table->get_field($_) || $_ } @{$self->field_names(@_) || []};
196 return wantarray ? @tables
203 Read-only method to return a list or array ref of the field names. Returns undef
204 or an empty list if the constraint has no fields set. Useful if you want to
205 avoid the overload magic of the Field objects returned by the fields method.
207 my @names = $constraint->field_names;
211 with ListAttr field_names => ( uniq => 1, undef_if_empty => 1 );
215 Get or set the constraint's match_type. Only valid values are "full"
216 "partial" and "simple"
218 my $match_type = $constraint->match_type('FULL');
224 default => quote_sub(q{ '' }),
225 coerce => quote_sub(q{ lc $_[0] }),
228 throw("Invalid match type: $arg")
229 if $arg && !($arg eq 'full' || $arg eq 'partial' || $arg eq 'simple');
233 around match_type => \&ex2err;
237 Get or set the constraint's name.
239 my $name = $constraint->name('foo');
243 has name => ( is => 'rw', default => quote_sub(q{ '' }) );
246 my ($orig, $self, $arg) = @_;
247 $self->$orig($arg || ());
252 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
253 Returns an array or array reference.
255 $constraint->options('NORELY');
256 my @options = $constraint->options;
260 with ListAttr options => ();
264 Get or set the constraint's "on delete" action.
266 my $action = $constraint->on_delete('cascade');
270 has on_delete => ( is => 'rw', default => quote_sub(q{ '' }) );
272 around on_delete => sub {
273 my ($orig, $self, $arg) = @_;
274 $self->$orig($arg || ());
279 Get or set the constraint's "on update" action.
281 my $action = $constraint->on_update('no action');
285 has on_update => ( is => 'rw', default => quote_sub(q{ '' }) );
287 around on_update => sub {
288 my ($orig, $self, $arg) = @_;
289 $self->$orig($arg || ());
292 =head2 reference_fields
294 Gets and set the fields in the referred table. Accepts a string, list or
295 arrayref; returns an array or array reference.
297 $constraint->reference_fields('id');
298 $constraint->reference_fields('id', 'name');
299 $constraint->reference_fields( 'id, name' );
300 $constraint->reference_fields( [ 'id', 'name' ] );
301 $constraint->reference_fields( qw[ id name ] );
303 my @reference_fields = $constraint->reference_fields;
307 with ListAttr reference_fields => (
313 sub _build_reference_fields {
316 my $table = $self->table or throw('No table');
317 my $schema = $table->schema or throw('No schema');
318 if ( my $ref_table_name = $self->reference_table ) {
319 my $ref_table = $schema->get_table( $ref_table_name ) or
320 throw("Can't find table '$ref_table_name'");
322 if ( my $constraint = $ref_table->primary_key ) {
323 return [ $constraint->fields ];
327 'No reference fields defined and cannot find primary key in ',
328 "reference table '$ref_table_name'"
334 =head2 reference_table
336 Get or set the table referred to by the constraint.
338 my $reference_table = $constraint->reference_table('foo');
342 has reference_table => ( is => 'rw', default => quote_sub(q{ '' }) );
346 Get or set the constraint's table object.
348 my $table = $field->table;
352 has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
354 around table => \&ex2err;
358 Get or set the constraint's type.
360 my $type = $constraint->type( PRIMARY_KEY );
366 default => quote_sub(q{ '' }),
368 throw("Invalid constraint type: $_[0]")
369 if $_[0] && !$VALID_CONSTRAINT_TYPE{ $_[0] };
371 coerce => quote_sub(q{ (my $t = $_[0]) =~ s/_/ /g; uc $t }),
374 around type => \&ex2err;
378 Determines if this constraint is the same as another
380 my $isIdentical = $constraint1->equals( $constraint2 );
384 around equals => sub {
388 my $case_insensitive = shift;
389 my $ignore_constraint_names = shift;
391 return 0 unless $self->$orig($other);
392 return 0 unless $self->type eq $other->type;
393 unless ($ignore_constraint_names) {
394 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
396 return 0 unless $self->deferrable eq $other->deferrable;
397 #return 0 unless $self->is_valid eq $other->is_valid;
398 return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
399 : $self->table->name eq $other->table->name;
400 return 0 unless $self->expression eq $other->expression;
402 # Check fields, regardless of order
403 my %otherFields = (); # create a hash of the other fields
404 foreach my $otherField ($other->fields) {
405 $otherField = uc($otherField) if $case_insensitive;
406 $otherFields{$otherField} = 1;
408 foreach my $selfField ($self->fields) { # check for self fields in hash
409 $selfField = uc($selfField) if $case_insensitive;
410 return 0 unless $otherFields{$selfField};
411 delete $otherFields{$selfField};
413 # Check all other fields were accounted for
414 return 0 unless keys %otherFields == 0;
416 # Check reference fields, regardless of order
417 my %otherRefFields = (); # create a hash of the other reference fields
418 foreach my $otherRefField ($other->reference_fields) {
419 $otherRefField = uc($otherRefField) if $case_insensitive;
420 $otherRefFields{$otherRefField} = 1;
422 foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash
423 $selfRefField = uc($selfRefField) if $case_insensitive;
424 return 0 unless $otherRefFields{$selfRefField};
425 delete $otherRefFields{$selfRefField};
427 # Check all other reference fields were accounted for
428 return 0 unless keys %otherRefFields == 0;
430 return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table;
431 return 0 unless $self->match_type eq $other->match_type;
432 return 0 unless $self->on_delete eq $other->on_delete;
433 return 0 unless $self->on_update eq $other->on_update;
434 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
435 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
439 # Must come after all 'has' declarations
440 around new => \&ex2err;
448 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.