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');
93 coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
94 default => quote_sub(q{ 1 }),
99 Gets and set the expression used in a CHECK constraint.
101 my $expression = $constraint->expression('...');
105 has expression => ( is => 'rw', default => quote_sub(q{ '' }) );
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;
215 with ListAttr field_names => ( uniq => 1, undef_if_empty => 1 );
219 Get or set the constraint's match_type. Only valid values are "full"
220 "partial" and "simple"
222 my $match_type = $constraint->match_type('FULL');
228 default => quote_sub(q{ '' }),
229 coerce => quote_sub(q{ lc $_[0] }),
232 throw("Invalid match type: $arg")
233 if $arg && !($arg eq 'full' || $arg eq 'partial' || $arg eq 'simple');
237 around match_type => \&ex2err;
241 Get or set the constraint's name.
243 my $name = $constraint->name('foo');
247 has name => ( is => 'rw', default => quote_sub(q{ '' }) );
250 my ($orig, $self, $arg) = @_;
251 $self->$orig($arg || ());
256 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
257 Returns an array or array reference.
259 $constraint->options('NORELY');
260 my @options = $constraint->options;
264 with ListAttr options => ();
268 Get or set the constraint's "on delete" action.
270 my $action = $constraint->on_delete('cascade');
274 has on_delete => ( is => 'rw', default => quote_sub(q{ '' }) );
276 around on_delete => sub {
277 my ($orig, $self, $arg) = @_;
278 $self->$orig($arg || ());
283 Get or set the constraint's "on update" action.
285 my $action = $constraint->on_update('no action');
289 has on_update => ( is => 'rw', default => quote_sub(q{ '' }) );
291 around on_update => sub {
292 my ($orig, $self, $arg) = @_;
293 $self->$orig($arg || ());
296 =head2 reference_fields
298 Gets and set the fields in the referred table. Accepts a string, list or
299 arrayref; returns an array or array reference.
301 $constraint->reference_fields('id');
302 $constraint->reference_fields('id', 'name');
303 $constraint->reference_fields( 'id, name' );
304 $constraint->reference_fields( [ 'id', 'name' ] );
305 $constraint->reference_fields( qw[ id name ] );
307 my @reference_fields = $constraint->reference_fields;
311 with ListAttr reference_fields => (
317 sub _build_reference_fields {
320 my $table = $self->table or throw('No table');
321 my $schema = $table->schema or throw('No schema');
322 if ( my $ref_table_name = $self->reference_table ) {
323 my $ref_table = $schema->get_table( $ref_table_name ) or
324 throw("Can't find table '$ref_table_name'");
326 if ( my $constraint = $ref_table->primary_key ) {
327 return [ $constraint->fields ];
331 'No reference fields defined and cannot find primary key in ',
332 "reference table '$ref_table_name'"
338 =head2 reference_table
340 Get or set the table referred to by the constraint.
342 my $reference_table = $constraint->reference_table('foo');
346 has reference_table => ( is => 'rw', default => quote_sub(q{ '' }) );
350 Get or set the constraint's table object.
352 my $table = $field->table;
356 has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
358 around table => \&ex2err;
362 Get or set the constraint's type.
364 my $type = $constraint->type( PRIMARY_KEY );
370 default => quote_sub(q{ '' }),
372 throw("Invalid constraint type: $_[0]")
373 if $_[0] && !$VALID_CONSTRAINT_TYPE{ $_[0] };
375 coerce => quote_sub(q{ (my $t = $_[0]) =~ s/_/ /g; uc $t }),
378 around type => \&ex2err;
382 Determines if this constraint is the same as another
384 my $isIdentical = $constraint1->equals( $constraint2 );
388 around equals => sub {
392 my $case_insensitive = shift;
393 my $ignore_constraint_names = shift;
395 return 0 unless $self->$orig($other);
396 return 0 unless $self->type eq $other->type;
397 unless ($ignore_constraint_names) {
398 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
400 return 0 unless $self->deferrable eq $other->deferrable;
401 #return 0 unless $self->is_valid eq $other->is_valid;
402 return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
403 : $self->table->name eq $other->table->name;
404 return 0 unless $self->expression eq $other->expression;
406 # Check fields, regardless of order
407 my %otherFields = (); # create a hash of the other fields
408 foreach my $otherField ($other->fields) {
409 $otherField = uc($otherField) if $case_insensitive;
410 $otherFields{$otherField} = 1;
412 foreach my $selfField ($self->fields) { # check for self fields in hash
413 $selfField = uc($selfField) if $case_insensitive;
414 return 0 unless $otherFields{$selfField};
415 delete $otherFields{$selfField};
417 # Check all other fields were accounted for
418 return 0 unless keys %otherFields == 0;
420 # Check reference fields, regardless of order
421 my %otherRefFields = (); # create a hash of the other reference fields
422 foreach my $otherRefField ($other->reference_fields) {
423 $otherRefField = uc($otherRefField) if $case_insensitive;
424 $otherRefFields{$otherRefField} = 1;
426 foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash
427 $selfRefField = uc($selfRefField) if $case_insensitive;
428 return 0 unless $otherRefFields{$selfRefField};
429 delete $otherRefFields{$selfRefField};
431 # Check all other reference fields were accounted for
432 return 0 unless keys %otherRefFields == 0;
434 return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table;
435 return 0 unless $self->match_type eq $other->match_type;
436 return 0 unless $self->on_delete eq $other->on_delete;
437 return 0 unless $self->on_update eq $other->on_update;
438 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
439 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
443 # Must come after all 'has' declarations
444 around new => \&ex2err;
452 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.