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 'parse_list_arg';
30 use base 'SQL::Translator::Schema::Object';
32 use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
36 my %VALID_CONSTRAINT_TYPE = (
44 # ----------------------------------------------------------------------
46 __PACKAGE__->_attributes( qw/
47 table name type fields reference_fields reference_table
48 match_type on_delete on_update expression deferrable
51 # Override to remove empty arrays from args.
52 # t/14postgres-parser breaks without this.
61 my $schema = SQL::Translator::Schema::Constraint->new(
62 table => $table, # table to which it belongs
63 type => 'foreign_key', # type of table constraint
64 name => 'fk_phone_id', # name of the constraint
65 fields => 'phone_id', # field in the referring table
66 reference_fields => 'phone_id', # referenced field
67 reference_table => 'phone', # referenced table
68 match_type => 'full', # how to match
69 on_delete => 'cascade', # what to do on deletes
70 on_update => '', # what to do on updates
76 foreach ( values %{$_[0]} ) { $_ = undef if ref($_) eq "ARRAY" && ! @$_; }
77 $self->SUPER::init(@_);
80 # ----------------------------------------------------------------------
87 Get or set whether the constraint is deferrable. If not defined,
88 then returns "1." The argument is evaluated by Perl for True or
89 False, so the following are eqivalent:
91 $deferrable = $field->deferrable(0);
92 $deferrable = $field->deferrable('');
93 $deferrable = $field->deferrable('0');
97 my ( $self, $arg ) = @_;
100 $self->{'deferrable'} = $arg ? 1 : 0;
103 return defined $self->{'deferrable'} ? $self->{'deferrable'} : 1;
106 # ----------------------------------------------------------------------
113 Gets and set the expression used in a CHECK constraint.
115 my $expression = $constraint->expression('...');
121 if ( my $arg = shift ) {
123 $self->{'expression'} = $arg;
126 return $self->{'expression'} || '';
129 # ----------------------------------------------------------------------
136 Determine whether the constraint is valid or not.
138 my $ok = $constraint->is_valid;
143 my $type = $self->type or return $self->error('No type');
144 my $table = $self->table or return $self->error('No table');
145 my @fields = $self->fields or return $self->error('No fields');
146 my $table_name = $table->name or return $self->error('No table name');
148 for my $f ( @fields ) {
149 next if $table->get_field( $f );
151 "Constraint references non-existent field '$f' ",
152 "in table '$table_name'"
156 my $schema = $table->schema or return $self->error(
157 'Table ', $table->name, ' has no schema object'
160 if ( $type eq FOREIGN_KEY ) {
161 return $self->error('Only one field allowed for foreign key')
162 if scalar @fields > 1;
164 my $ref_table_name = $self->reference_table or
165 return $self->error('No reference table');
167 my $ref_table = $schema->get_table( $ref_table_name ) or
168 return $self->error("No table named '$ref_table_name' in schema");
170 my @ref_fields = $self->reference_fields or return;
172 return $self->error('Only one field allowed for foreign key reference')
173 if scalar @ref_fields > 1;
175 for my $ref_field ( @ref_fields ) {
176 next if $ref_table->get_field( $ref_field );
178 "Constraint from field(s) ",
179 join(', ', map {qq['$table_name.$_']} @fields),
180 " to non-existent field '$ref_table_name.$ref_field'"
184 elsif ( $type eq CHECK_C ) {
185 return $self->error('No expression for CHECK') unless
192 # ----------------------------------------------------------------------
199 Gets and set the fields the constraint is on. Accepts a string, list or
200 arrayref; returns an array or array reference. Will unique the field
201 names and keep them in order by the first occurrence of a field name.
203 The fields are returned as Field objects if they exist or as plain
204 names if not. (If you just want the names and want to avoid the Field's overload
205 magic use L<field_names>).
207 Returns undef or an empty list if the constraint has no fields set.
209 $constraint->fields('id');
210 $constraint->fields('id', 'name');
211 $constraint->fields( 'id, name' );
212 $constraint->fields( [ 'id', 'name' ] );
213 $constraint->fields( qw[ id name ] );
215 my @fields = $constraint->fields;
220 my $fields = parse_list_arg( @_ );
223 my ( %unique, @unique );
224 for my $f ( @$fields ) {
225 next if $unique{ $f };
230 $self->{'fields'} = \@unique;
233 if ( @{ $self->{'fields'} || [] } ) {
234 # We have to return fields that don't exist on the table as names in
235 # case those fields havn't been created yet.
237 $self->table->get_field($_) || $_ } @{ $self->{'fields'} };
238 return wantarray ? @ret : \@ret;
241 return wantarray ? () : undef;
245 # ----------------------------------------------------------------------
250 Read-only method to return a list or array ref of the field names. Returns undef
251 or an empty list if the constraint has no fields set. Useful if you want to
252 avoid the overload magic of the Field objects returned by the fields method.
254 my @names = $constraint->field_names;
259 return wantarray ? @{ $self->{'fields'} || [] } : ($self->{'fields'} || '');
262 # ----------------------------------------------------------------------
269 Get or set the constraint's match_type. Only valid values are "full"
270 "partial" and "simple"
272 my $match_type = $constraint->match_type('FULL');
276 my ( $self, $arg ) = @_;
280 return $self->error("Invalid match type: $arg")
281 unless $arg eq 'full' || $arg eq 'partial' || $arg eq 'simple';
282 $self->{'match_type'} = $arg;
285 return $self->{'match_type'} || '';
288 # ----------------------------------------------------------------------
295 Get or set the constraint's name.
297 my $name = $constraint->name('foo');
302 my $arg = shift || '';
303 $self->{'name'} = $arg if $arg;
304 return $self->{'name'} || '';
307 # ----------------------------------------------------------------------
314 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
315 Returns an array or array reference.
317 $constraint->options('NORELY');
318 my @options = $constraint->options;
323 my $options = parse_list_arg( @_ );
325 push @{ $self->{'options'} }, @$options;
327 if ( ref $self->{'options'} ) {
328 return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
331 return wantarray ? () : [];
336 # ----------------------------------------------------------------------
343 Get or set the constraint's "on delete" action.
345 my $action = $constraint->on_delete('cascade');
351 if ( my $arg = shift ) {
353 $self->{'on_delete'} = $arg;
356 return $self->{'on_delete'} || '';
359 # ----------------------------------------------------------------------
366 Get or set the constraint's "on update" action.
368 my $action = $constraint->on_update('no action');
374 if ( my $arg = shift ) {
376 $self->{'on_update'} = $arg;
379 return $self->{'on_update'} || '';
382 # ----------------------------------------------------------------------
383 sub reference_fields {
387 =head2 reference_fields
389 Gets and set the fields in the referred table. Accepts a string, list or
390 arrayref; returns an array or array reference.
392 $constraint->reference_fields('id');
393 $constraint->reference_fields('id', 'name');
394 $constraint->reference_fields( 'id, name' );
395 $constraint->reference_fields( [ 'id', 'name' ] );
396 $constraint->reference_fields( qw[ id name ] );
398 my @reference_fields = $constraint->reference_fields;
403 my $fields = parse_list_arg( @_ );
406 $self->{'reference_fields'} = $fields;
409 # Nothing set so try and derive it from the other constraint data
410 unless ( ref $self->{'reference_fields'} ) {
411 my $table = $self->table or return $self->error('No table');
412 my $schema = $table->schema or return $self->error('No schema');
413 if ( my $ref_table_name = $self->reference_table ) {
414 my $ref_table = $schema->get_table( $ref_table_name ) or
415 return $self->error("Can't find table '$ref_table_name'");
417 if ( my $constraint = $ref_table->primary_key ) {
418 $self->{'reference_fields'} = [ $constraint->fields ];
422 'No reference fields defined and cannot find primary key in ',
423 "reference table '$ref_table_name'"
427 # No ref table so we are not that sort of constraint, hence no ref
428 # fields. So we let the return below return an empty list.
431 if ( ref $self->{'reference_fields'} ) {
433 ? @{ $self->{'reference_fields'} }
434 : $self->{'reference_fields'};
437 return wantarray ? () : [];
441 # ----------------------------------------------------------------------
442 sub reference_table {
446 =head2 reference_table
448 Get or set the table referred to by the constraint.
450 my $reference_table = $constraint->reference_table('foo');
455 $self->{'reference_table'} = shift if @_;
456 return $self->{'reference_table'} || '';
459 # ----------------------------------------------------------------------
466 Get or set the constraint's table object.
468 my $table = $field->table;
473 if ( my $arg = shift ) {
474 return $self->error('Not a table object') unless
475 UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
476 $self->{'table'} = $arg;
479 return $self->{'table'};
482 # ----------------------------------------------------------------------
489 Get or set the constraint's type.
491 my $type = $constraint->type( PRIMARY_KEY );
495 my ( $self, $type ) = @_;
500 return $self->error("Invalid constraint type: $type")
501 unless $VALID_CONSTRAINT_TYPE{ $type };
502 $self->{'type'} = $type;
505 return $self->{'type'} || '';
508 # ----------------------------------------------------------------------
515 Determines if this constraint is the same as another
517 my $isIdentical = $constraint1->equals( $constraint2 );
523 my $case_insensitive = shift;
524 my $ignore_constraint_names = shift;
526 return 0 unless $self->SUPER::equals($other);
527 return 0 unless $self->type eq $other->type;
528 unless ($ignore_constraint_names) {
529 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
531 return 0 unless $self->deferrable eq $other->deferrable;
532 #return 0 unless $self->is_valid eq $other->is_valid;
533 return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
534 : $self->table->name eq $other->table->name;
535 return 0 unless $self->expression eq $other->expression;
537 # Check fields, regardless of order
538 my %otherFields = (); # create a hash of the other fields
539 foreach my $otherField ($other->fields) {
540 $otherField = uc($otherField) if $case_insensitive;
541 $otherFields{$otherField} = 1;
543 foreach my $selfField ($self->fields) { # check for self fields in hash
544 $selfField = uc($selfField) if $case_insensitive;
545 return 0 unless $otherFields{$selfField};
546 delete $otherFields{$selfField};
548 # Check all other fields were accounted for
549 return 0 unless keys %otherFields == 0;
551 # Check reference fields, regardless of order
552 my %otherRefFields = (); # create a hash of the other reference fields
553 foreach my $otherRefField ($other->reference_fields) {
554 $otherRefField = uc($otherRefField) if $case_insensitive;
555 $otherRefFields{$otherRefField} = 1;
557 foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash
558 $selfRefField = uc($selfRefField) if $case_insensitive;
559 return 0 unless $otherRefFields{$selfRefField};
560 delete $otherRefFields{$selfRefField};
562 # Check all other reference fields were accounted for
563 return 0 unless keys %otherRefFields == 0;
565 return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table;
566 return 0 unless $self->match_type eq $other->match_type;
567 return 0 unless $self->on_delete eq $other->on_delete;
568 return 0 unless $self->on_update eq $other->on_update;
569 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
570 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
574 # ----------------------------------------------------------------------
577 undef $self->{'table'}; # destroy cyclical reference
582 # ----------------------------------------------------------------------
588 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.