1 package SQL::Translator::Schema::Constraint;
3 # ----------------------------------------------------------------------
4 # $Id: Constraint.pm,v 1.19 2005-08-10 16:42:47 duality72 Exp $
5 # ----------------------------------------------------------------------
6 # Copyright (C) 2002-4 SQLFairy Authors
8 # This program is free software; you can redistribute it and/or
9 # modify it under the terms of the GNU General Public License as
10 # published by the Free Software Foundation; version 2.
12 # This program is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 # General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program; if not, write to the Free Software
19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
21 # -------------------------------------------------------------------
27 SQL::Translator::Schema::Constraint - SQL::Translator constraint object
31 use SQL::Translator::Schema::Constraint;
32 my $constraint = SQL::Translator::Schema::Constraint->new(
40 C<SQL::Translator::Schema::Constraint> is the constraint object.
47 use SQL::Translator::Schema::Constants;
48 use SQL::Translator::Utils 'parse_list_arg';
50 use base 'SQL::Translator::Schema::Object';
52 use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
54 $VERSION = sprintf "%d.%02d", q$Revision: 1.19 $ =~ /(\d+)\.(\d+)/;
56 my %VALID_CONSTRAINT_TYPE = (
64 # ----------------------------------------------------------------------
66 __PACKAGE__->_attributes( qw/
67 table name type fields reference_fields reference_table
68 match_type on_delete on_update expression deferrable
71 # Override to remove empty arrays from args.
72 # t/14postgres-parser breaks without this.
81 my $schema = SQL::Translator::Schema::Constraint->new(
82 table => $table, # table to which it belongs
83 type => 'foreign_key', # type of table constraint
84 name => 'fk_phone_id', # name of the constraint
85 fields => 'phone_id', # field in the referring table
86 reference_fields => 'phone_id', # referenced field
87 reference_table => 'phone', # referenced table
88 match_type => 'full', # how to match
89 on_delete => 'cascade', # what to do on deletes
90 on_update => '', # what to do on updates
96 foreach ( values %{$_[0]} ) { $_ = undef if ref($_) eq "ARRAY" && ! @$_; }
97 $self->SUPER::init(@_);
100 # ----------------------------------------------------------------------
107 Get or set whether the constraint is deferrable. If not defined,
108 then returns "1." The argument is evaluated by Perl for True or
109 False, so the following are eqivalent:
111 $deferrable = $field->deferrable(0);
112 $deferrable = $field->deferrable('');
113 $deferrable = $field->deferrable('0');
117 my ( $self, $arg ) = @_;
119 if ( defined $arg ) {
120 $self->{'deferrable'} = $arg ? 1 : 0;
123 return defined $self->{'deferrable'} ? $self->{'deferrable'} : 1;
126 # ----------------------------------------------------------------------
133 Gets and set the expression used in a CHECK constraint.
135 my $expression = $constraint->expression('...');
141 if ( my $arg = shift ) {
143 $self->{'expression'} = $arg;
146 return $self->{'expression'} || '';
149 # ----------------------------------------------------------------------
156 Determine whether the constraint is valid or not.
158 my $ok = $constraint->is_valid;
163 my $type = $self->type or return $self->error('No type');
164 my $table = $self->table or return $self->error('No table');
165 my @fields = $self->fields or return $self->error('No fields');
166 my $table_name = $table->name or return $self->error('No table name');
168 for my $f ( @fields ) {
169 next if $table->get_field( $f );
171 "Constraint references non-existent field '$f' ",
172 "in table '$table_name'"
176 my $schema = $table->schema or return $self->error(
177 'Table ', $table->name, ' has no schema object'
180 if ( $type eq FOREIGN_KEY ) {
181 return $self->error('Only one field allowed for foreign key')
182 if scalar @fields > 1;
184 my $ref_table_name = $self->reference_table or
185 return $self->error('No reference table');
187 my $ref_table = $schema->get_table( $ref_table_name ) or
188 return $self->error("No table named '$ref_table_name' in schema");
190 my @ref_fields = $self->reference_fields or return;
192 return $self->error('Only one field allowed for foreign key reference')
193 if scalar @ref_fields > 1;
195 for my $ref_field ( @ref_fields ) {
196 next if $ref_table->get_field( $ref_field );
198 "Constraint from field(s) ",
199 join(', ', map {qq['$table_name.$_']} @fields),
200 " to non-existent field '$ref_table_name.$ref_field'"
204 elsif ( $type eq CHECK_C ) {
205 return $self->error('No expression for CHECK') unless
212 # ----------------------------------------------------------------------
219 Gets and set the fields the constraint is on. Accepts a string, list or
220 arrayref; returns an array or array reference. Will unique the field
221 names and keep them in order by the first occurrence of a field name.
223 The fields are returned as Field objects if they exist or as plain
224 names if not. (If you just want the names and want to avoid the Field's overload
225 magic use L<field_names>).
227 Returns undef or an empty list if the constraint has no fields set.
229 $constraint->fields('id');
230 $constraint->fields('id', 'name');
231 $constraint->fields( 'id, name' );
232 $constraint->fields( [ 'id', 'name' ] );
233 $constraint->fields( qw[ id name ] );
235 my @fields = $constraint->fields;
240 my $fields = parse_list_arg( @_ );
243 my ( %unique, @unique );
244 for my $f ( @$fields ) {
245 next if $unique{ $f };
250 $self->{'fields'} = \@unique;
253 if ( @{ $self->{'fields'} || [] } ) {
254 # We have to return fields that don't exist on the table as names in
255 # case those fields havn't been created yet.
257 $self->table->get_field($_) || $_ } @{ $self->{'fields'} };
258 return wantarray ? @ret : \@ret;
261 return wantarray ? () : undef;
265 # ----------------------------------------------------------------------
270 Read-only method to return a list or array ref of the field names. Returns undef
271 or an empty list if the constraint has no fields set. Usefull if you want to
272 avoid the overload magic of the Field objects returned by the fields method.
274 my @names = $constraint->field_names;
279 return wantarray ? @{ $self->{'fields'} || [] } : ($self->{'fields'} || '');
282 # ----------------------------------------------------------------------
289 Get or set the constraint's match_type. Only valid values are "full"
292 my $match_type = $constraint->match_type('FULL');
298 if ( my $arg = lc shift ) {
299 return $self->error("Invalid match type: $arg")
300 unless $arg eq 'full' || $arg eq 'partial';
301 $self->{'match_type'} = $arg;
304 return $self->{'match_type'} || '';
307 # ----------------------------------------------------------------------
314 Get or set the constraint's name.
316 my $name = $constraint->name('foo');
321 my $arg = shift || '';
322 $self->{'name'} = $arg if $arg;
323 return $self->{'name'} || '';
326 # ----------------------------------------------------------------------
333 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
334 Returns an array or array reference.
336 $constraint->options('NORELY');
337 my @options = $constraint->options;
342 my $options = parse_list_arg( @_ );
344 push @{ $self->{'options'} }, @$options;
346 if ( ref $self->{'options'} ) {
347 return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
350 return wantarray ? () : [];
355 # ----------------------------------------------------------------------
362 Get or set the constraint's "on delete" action.
364 my $action = $constraint->on_delete('cascade');
370 if ( my $arg = shift ) {
372 $self->{'on_delete'} = $arg;
375 return $self->{'on_delete'} || '';
378 # ----------------------------------------------------------------------
385 Get or set the constraint's "on update" action.
387 my $action = $constraint->on_update('no action');
393 if ( my $arg = shift ) {
395 $self->{'on_update'} = $arg;
398 return $self->{'on_update'} || '';
401 # ----------------------------------------------------------------------
402 sub reference_fields {
406 =head2 reference_fields
408 Gets and set the fields in the referred table. Accepts a string, list or
409 arrayref; returns an array or array reference.
411 $constraint->reference_fields('id');
412 $constraint->reference_fields('id', 'name');
413 $constraint->reference_fields( 'id, name' );
414 $constraint->reference_fields( [ 'id', 'name' ] );
415 $constraint->reference_fields( qw[ id name ] );
417 my @reference_fields = $constraint->reference_fields;
422 my $fields = parse_list_arg( @_ );
425 $self->{'reference_fields'} = $fields;
428 # Nothing set so try and derive it from the other constraint data
429 unless ( ref $self->{'reference_fields'} ) {
430 my $table = $self->table or return $self->error('No table');
431 my $schema = $table->schema or return $self->error('No schema');
432 if ( my $ref_table_name = $self->reference_table ) {
433 my $ref_table = $schema->get_table( $ref_table_name ) or
434 return $self->error("Can't find table '$ref_table_name'");
436 if ( my $constraint = $ref_table->primary_key ) {
437 $self->{'reference_fields'} = [ $constraint->fields ];
441 'No reference fields defined and cannot find primary key in ',
442 "reference table '$ref_table_name'"
446 # No ref table so we are not that sort of constraint, hence no ref
447 # fields. So we let the return below return an empty list.
450 if ( ref $self->{'reference_fields'} ) {
452 ? @{ $self->{'reference_fields'} }
453 : $self->{'reference_fields'};
456 return wantarray ? () : [];
460 # ----------------------------------------------------------------------
461 sub reference_table {
465 =head2 reference_table
467 Get or set the table referred to by the constraint.
469 my $reference_table = $constraint->reference_table('foo');
474 $self->{'reference_table'} = shift if @_;
475 return $self->{'reference_table'} || '';
478 # ----------------------------------------------------------------------
485 Get or set the constraint's table object.
487 my $table = $field->table;
492 if ( my $arg = shift ) {
493 return $self->error('Not a table object') unless
494 UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
495 $self->{'table'} = $arg;
498 return $self->{'table'};
501 # ----------------------------------------------------------------------
508 Get or set the constraint's type.
510 my $type = $constraint->type( PRIMARY_KEY );
516 if ( my $type = uc shift ) {
518 return $self->error("Invalid constraint type: $type")
519 unless $VALID_CONSTRAINT_TYPE{ $type };
520 $self->{'type'} = $type;
523 return $self->{'type'} || '';
526 # ----------------------------------------------------------------------
533 Determines if this constraint is the same as another
535 my $isIdentical = $constraint1->equals( $constraint2 );
541 my $case_insensitive = shift;
543 return 0 unless $self->SUPER::equals($other);
544 return 0 unless $self->type eq $other->type;
545 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
546 return 0 unless $self->deferrable eq $other->deferrable;
547 #return 0 unless $self->is_valid eq $other->is_valid;
548 return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
549 : $self->table->name eq $other->table->name;
550 return 0 unless $self->expression eq $other->expression;
551 my $selfFields = join(":", $self->fields);
552 my $otherFields = join(":", $other->fields);
553 return 0 unless $case_insensitive ? uc($selfFields) eq uc($otherFields) : $selfFields eq $otherFields;
554 return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table;
555 my $selfRefFields = join(":", $self->reference_fields);
556 my $otherRefFields = join(":", $other->reference_fields);
557 return 0 unless $case_insensitive ? uc($selfRefFields) eq uc($otherRefFields) : $selfRefFields eq $otherRefFields;
558 return 0 unless $self->match_type eq $other->match_type;
559 return 0 unless $self->on_delete eq $other->on_delete;
560 return 0 unless $self->on_update eq $other->on_update;
561 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
562 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
566 # ----------------------------------------------------------------------
569 undef $self->{'table'}; # destroy cyclical reference
574 # ----------------------------------------------------------------------
580 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.