1 package SQL::Translator::Schema::Constraint;
3 # ----------------------------------------------------------------------
4 # $Id: Constraint.pm,v 1.13 2004-03-29 11:18:12 grommit 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.
48 use SQL::Translator::Schema::Constants;
49 use SQL::Translator::Utils 'parse_list_arg';
51 use base 'Class::Base';
52 use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
54 $VERSION = sprintf "%d.%02d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/;
56 my %VALID_CONSTRAINT_TYPE = (
64 # ----------------------------------------------------------------------
73 my $schema = SQL::Translator::Schema::Constraint->new(
74 table => $table, # table to which it belongs
75 type => 'foreign_key', # type of table constraint
76 name => 'fk_phone_id', # name of the constraint
77 fields => 'phone_id', # field in the referring table
78 reference_fields => 'phone_id', # referenced field
79 reference_table => 'phone', # referenced table
80 match_type => 'full', # how to match
81 on_delete => 'cascade', # what to do on deletes
82 on_update => '', # what to do on updates
87 my ( $self, $config ) = @_;
89 table name type fields reference_fields reference_table
90 match_type on_delete on_update expression
93 for my $arg ( @fields ) {
94 next unless $config->{ $arg };
95 next if ref $config->{ $arg } eq 'ARRAY' && ! @{ $config->{ $arg } };
96 defined $self->$arg( $config->{ $arg } ) or return;
102 # ----------------------------------------------------------------------
109 Get or set whether the constraint is deferrable. If not defined,
110 then returns "1." The argument is evaluated by Perl for True or
111 False, so the following are eqivalent:
113 $deferrable = $field->deferrable(0);
114 $deferrable = $field->deferrable('');
115 $deferrable = $field->deferrable('0');
119 my ( $self, $arg ) = @_;
121 if ( defined $arg ) {
122 $self->{'deferrable'} = $arg ? 1 : 0;
125 return defined $self->{'deferrable'} ? $self->{'deferrable'} : 1;
128 # ----------------------------------------------------------------------
135 Gets and set the expression used in a CHECK constraint.
137 my $expression = $constraint->expression('...');
143 if ( my $arg = shift ) {
145 $self->{'expression'} = $arg;
148 return $self->{'expression'} || '';
151 # ----------------------------------------------------------------------
158 Determine whether the constraint is valid or not.
160 my $ok = $constraint->is_valid;
165 my $type = $self->type or return $self->error('No type');
166 my $table = $self->table or return $self->error('No table');
167 my @fields = $self->fields or return $self->error('No fields');
168 my $table_name = $table->name or return $self->error('No table name');
170 for my $f ( @fields ) {
171 next if $table->get_field( $f );
173 "Constraint references non-existent field '$f' ",
174 "in table '$table_name'"
178 my $schema = $table->schema or return $self->error(
179 'Table ', $table->name, ' has no schema object'
182 if ( $type eq FOREIGN_KEY ) {
183 return $self->error('Only one field allowed for foreign key')
184 if scalar @fields > 1;
186 my $ref_table_name = $self->reference_table or
187 return $self->error('No reference table');
189 my $ref_table = $schema->get_table( $ref_table_name ) or
190 return $self->error("No table named '$ref_table_name' in schema");
192 my @ref_fields = $self->reference_fields or return;
194 return $self->error('Only one field allowed for foreign key reference')
195 if scalar @ref_fields > 1;
197 for my $ref_field ( @ref_fields ) {
198 next if $ref_table->get_field( $ref_field );
200 "Constraint from field(s) ",
201 join(', ', map {qq['$table_name.$_']} @fields),
202 " to non-existent field '$ref_table_name.$ref_field'"
206 elsif ( $type eq CHECK_C ) {
207 return $self->error('No expression for CHECK') unless
214 # ----------------------------------------------------------------------
221 Gets and set the fields the constraint is on. Accepts a string, list or
222 arrayref; returns an array or array reference. Will unique the field
223 names and keep them in order by the first occurrence of a field name.
225 The fields are returned as Field objects if they exist or as plain
226 names if not. (If you just want the names and want to avoid the Field's overload
227 magic use L<field_names>).
229 Returns undef or an empty list if the constraint has no fields set.
231 $constraint->fields('id');
232 $constraint->fields('id', 'name');
233 $constraint->fields( 'id, name' );
234 $constraint->fields( [ 'id', 'name' ] );
235 $constraint->fields( qw[ id name ] );
237 my @fields = $constraint->fields;
242 my $fields = parse_list_arg( @_ );
245 my ( %unique, @unique );
246 for my $f ( @$fields ) {
247 next if $unique{ $f };
252 $self->{'fields'} = \@unique;
255 if ( @{ $self->{'fields'} || [] } ) {
256 # We have to return fields that don't exist on the table as names in
257 # case those fields havn't been created yet.
259 $self->table->get_field($_) || $_ } @{ $self->{'fields'} };
260 return wantarray ? @ret : \@ret;
263 return wantarray ? () : undef;
267 # ----------------------------------------------------------------------
272 Read-only method to return a list or array ref of the field names. Returns undef
273 or an empty list if the constraint has no fields set. Usefull if you want to
274 avoid the overload magic of the Field objects returned by the fields method.
276 my @names = $constraint->field_names;
281 return wantarray ? @{ $self->{'fields'} } : $self->{'fields'};
284 # ----------------------------------------------------------------------
291 Get or set the constraint's match_type. Only valid values are "full"
294 my $match_type = $constraint->match_type('FULL');
300 if ( my $arg = lc shift ) {
301 return $self->error("Invalid match type: $arg")
302 unless $arg eq 'full' || $arg eq 'partial';
303 $self->{'match_type'} = $arg;
306 return $self->{'match_type'} || '';
309 # ----------------------------------------------------------------------
316 Get or set the constraint's name.
318 my $name = $constraint->name('foo');
323 my $arg = shift || '';
324 $self->{'name'} = $arg if $arg;
325 return $self->{'name'} || '';
328 # ----------------------------------------------------------------------
335 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
336 Returns an array or array reference.
338 $constraint->options('NORELY');
339 my @options = $constraint->options;
344 my $options = parse_list_arg( @_ );
346 push @{ $self->{'options'} }, @$options;
348 if ( ref $self->{'options'} ) {
349 return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
352 return wantarray ? () : [];
357 # ----------------------------------------------------------------------
364 Get or set the constraint's "on delete" action.
366 my $action = $constraint->on_delete('cascade');
372 if ( my $arg = shift ) {
374 $self->{'on_delete'} = $arg;
377 return $self->{'on_delete'} || '';
380 # ----------------------------------------------------------------------
387 Get or set the constraint's "on update" action.
389 my $action = $constraint->on_update('no action');
395 if ( my $arg = shift ) {
397 $self->{'on_update'} = $arg;
400 return $self->{'on_update'} || '';
403 # ----------------------------------------------------------------------
404 sub reference_fields {
408 =head2 reference_fields
410 Gets and set the fields in the referred table. Accepts a string, list or
411 arrayref; returns an array or array reference.
413 $constraint->reference_fields('id');
414 $constraint->reference_fields('id', 'name');
415 $constraint->reference_fields( 'id, name' );
416 $constraint->reference_fields( [ 'id', 'name' ] );
417 $constraint->reference_fields( qw[ id name ] );
419 my @reference_fields = $constraint->reference_fields;
424 my $fields = parse_list_arg( @_ );
427 $self->{'reference_fields'} = $fields;
430 # Nothing set so try and derive it from the other constraint data
431 unless ( ref $self->{'reference_fields'} ) {
432 my $table = $self->table or return $self->error('No table');
433 my $schema = $table->schema or return $self->error('No schema');
434 if ( my $ref_table_name = $self->reference_table ) {
435 my $ref_table = $schema->get_table( $ref_table_name ) or
436 return $self->error("Can't find table '$ref_table_name'");
438 if ( my $constraint = $ref_table->primary_key ) {
439 $self->{'reference_fields'} = [ $constraint->fields ];
443 'No reference fields defined and cannot find primary key in ',
444 "reference table '$ref_table_name'"
448 # No ref table so we are not that sort of constraint, hence no ref
449 # fields. So we let the return below return an empty list.
452 if ( ref $self->{'reference_fields'} ) {
454 ? @{ $self->{'reference_fields'} }
455 : $self->{'reference_fields'};
458 return wantarray ? () : [];
462 # ----------------------------------------------------------------------
463 sub reference_table {
467 =head2 reference_table
469 Get or set the table referred to by the constraint.
471 my $reference_table = $constraint->reference_table('foo');
476 $self->{'reference_table'} = shift if @_;
477 return $self->{'reference_table'} || '';
480 # ----------------------------------------------------------------------
487 Get or set the constraint's table object.
489 my $table = $field->table;
494 if ( my $arg = shift ) {
495 return $self->error('Not a table object') unless
496 UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
497 $self->{'table'} = $arg;
500 return $self->{'table'};
503 # ----------------------------------------------------------------------
510 Get or set the constraint's type.
512 my $type = $constraint->type( PRIMARY_KEY );
518 if ( my $type = uc shift ) {
520 return $self->error("Invalid constraint type: $type")
521 unless $VALID_CONSTRAINT_TYPE{ $type };
522 $self->{'type'} = $type;
525 return $self->{'type'} || '';
527 # ----------------------------------------------------------------------
530 undef $self->{'table'}; # destroy cyclical reference
535 # ----------------------------------------------------------------------
541 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.