Added Access data types.
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Schema / Constraint.pm
CommitLineData
3c5de62a 1package SQL::Translator::Schema::Constraint;
2
3# ----------------------------------------------------------------------
ebe49790 4# $Id: Constraint.pm,v 1.13 2004-03-29 11:18:12 grommit Exp $
3c5de62a 5# ----------------------------------------------------------------------
6606c4c6 6# Copyright (C) 2002-4 SQLFairy Authors
3c5de62a 7#
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.
11#
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.
16#
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
20# 02111-1307 USA
21# -------------------------------------------------------------------
22
23=pod
24
25=head1 NAME
26
27SQL::Translator::Schema::Constraint - SQL::Translator constraint object
28
29=head1 SYNOPSIS
30
31 use SQL::Translator::Schema::Constraint;
32 my $constraint = SQL::Translator::Schema::Constraint->new(
33 name => 'foo',
34 fields => [ id ],
43b9dc7a 35 type => PRIMARY_KEY,
3c5de62a 36 );
37
38=head1 DESCRIPTION
39
40C<SQL::Translator::Schema::Constraint> is the constraint object.
41
42=head1 METHODS
43
44=cut
45
46use strict;
47use Class::Base;
43b9dc7a 48use SQL::Translator::Schema::Constants;
752608d5 49use SQL::Translator::Utils 'parse_list_arg';
3c5de62a 50
51use base 'Class::Base';
52use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
53
ebe49790 54$VERSION = sprintf "%d.%02d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/;
3c5de62a 55
695c2da2 56my %VALID_CONSTRAINT_TYPE = (
43b9dc7a 57 PRIMARY_KEY, 1,
58 UNIQUE, 1,
59 CHECK_C, 1,
60 FOREIGN_KEY, 1,
695c2da2 61 NOT_NULL, 1,
62);
3c5de62a 63
64# ----------------------------------------------------------------------
65sub init {
66
67=pod
68
69=head2 new
70
71Object constructor.
72
73 my $schema = SQL::Translator::Schema::Constraint->new(
dedb8f3b 74 table => $table, # table to which it belongs
3c5de62a 75 type => 'foreign_key', # type of table constraint
dedb8f3b 76 name => 'fk_phone_id', # name of the constraint
77 fields => 'phone_id', # field in the referring table
65157eda 78 reference_fields => 'phone_id', # referenced field
79 reference_table => 'phone', # referenced table
3c5de62a 80 match_type => 'full', # how to match
2d034ab4 81 on_delete => 'cascade', # what to do on deletes
82 on_update => '', # what to do on updates
3c5de62a 83 );
84
85=cut
86
87 my ( $self, $config ) = @_;
752608d5 88 my @fields = qw[
89 table name type fields reference_fields reference_table
53ded04a 90 match_type on_delete on_update expression
752608d5 91 ];
3c5de62a 92
93 for my $arg ( @fields ) {
94 next unless $config->{ $arg };
53ded04a 95 next if ref $config->{ $arg } eq 'ARRAY' && ! @{ $config->{ $arg } };
695c2da2 96 defined $self->$arg( $config->{ $arg } ) or return;
3c5de62a 97 }
98
99 return $self;
100}
101
102# ----------------------------------------------------------------------
43b9dc7a 103sub deferrable {
104
105=pod
106
107=head2 deferrable
108
2d034ab4 109Get or set whether the constraint is deferrable. If not defined,
43b9dc7a 110then returns "1." The argument is evaluated by Perl for True or
111False, so the following are eqivalent:
112
113 $deferrable = $field->deferrable(0);
114 $deferrable = $field->deferrable('');
115 $deferrable = $field->deferrable('0');
116
117=cut
118
119 my ( $self, $arg ) = @_;
120
121 if ( defined $arg ) {
122 $self->{'deferrable'} = $arg ? 1 : 0;
123 }
124
125 return defined $self->{'deferrable'} ? $self->{'deferrable'} : 1;
126}
127
128# ----------------------------------------------------------------------
129sub expression {
130
131=pod
132
133=head2 expression
134
135Gets and set the expression used in a CHECK constraint.
136
137 my $expression = $constraint->expression('...');
138
139=cut
140
141 my $self = shift;
142
143 if ( my $arg = shift ) {
144 # check arg here?
145 $self->{'expression'} = $arg;
146 }
147
148 return $self->{'expression'} || '';
149}
150
151# ----------------------------------------------------------------------
152sub is_valid {
153
154=pod
155
156=head2 is_valid
157
158Determine whether the constraint is valid or not.
159
160 my $ok = $constraint->is_valid;
161
162=cut
163
164 my $self = shift;
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');
169
170 for my $f ( @fields ) {
171 next if $table->get_field( $f );
172 return $self->error(
173 "Constraint references non-existent field '$f' ",
174 "in table '$table_name'"
175 );
176 }
177
178 my $schema = $table->schema or return $self->error(
179 'Table ', $table->name, ' has no schema object'
180 );
181
182 if ( $type eq FOREIGN_KEY ) {
183 return $self->error('Only one field allowed for foreign key')
184 if scalar @fields > 1;
185
186 my $ref_table_name = $self->reference_table or
187 return $self->error('No reference table');
188
189 my $ref_table = $schema->get_table( $ref_table_name ) or
190 return $self->error("No table named '$ref_table_name' in schema");
191
192 my @ref_fields = $self->reference_fields or return;
193
194 return $self->error('Only one field allowed for foreign key reference')
195 if scalar @ref_fields > 1;
196
197 for my $ref_field ( @ref_fields ) {
198 next if $ref_table->get_field( $ref_field );
199 return $self->error(
200 "Constraint from field(s) ",
201 join(', ', map {qq['$table_name.$_']} @fields),
202 " to non-existent field '$ref_table_name.$ref_field'"
203 );
204 }
205 }
206 elsif ( $type eq CHECK_C ) {
207 return $self->error('No expression for CHECK') unless
208 $self->expression;
209 }
210
211 return 1;
212}
213
214# ----------------------------------------------------------------------
3c5de62a 215sub fields {
216
217=pod
218
219=head2 fields
220
43b9dc7a 221Gets and set the fields the constraint is on. Accepts a string, list or
222arrayref; returns an array or array reference. Will unique the field
223names and keep them in order by the first occurrence of a field name.
224
ac095e5e 225The fields are returned as Field objects if they exist or as plain
226names if not. (If you just want the names and want to avoid the Field's overload
227magic use L<field_names>).
228
229Returns undef or an empty list if the constraint has no fields set.
230
43b9dc7a 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 ] );
3c5de62a 236
43b9dc7a 237 my @fields = $constraint->fields;
3c5de62a 238
239=cut
240
241 my $self = shift;
752608d5 242 my $fields = parse_list_arg( @_ );
3c5de62a 243
244 if ( @$fields ) {
43b9dc7a 245 my ( %unique, @unique );
246 for my $f ( @$fields ) {
247 next if $unique{ $f };
248 $unique{ $f } = 1;
249 push @unique, $f;
250 }
251
252 $self->{'fields'} = \@unique;
3c5de62a 253 }
254
53ded04a 255 if ( @{ $self->{'fields'} || [] } ) {
ac095e5e 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.
258 my @ret = map {
259 $self->table->get_field($_) || $_ } @{ $self->{'fields'} };
260 return wantarray ? @ret : \@ret;
53ded04a 261 }
262 else {
263 return wantarray ? () : undef;
264 }
3c5de62a 265}
266
ebe49790 267# ----------------------------------------------------------------------
ac095e5e 268sub field_names {
269
270=head2 field_names
271
272Read-only method to return a list or array ref of the field names. Returns undef
273or an empty list if the constraint has no fields set. Usefull if you want to
274avoid the overload magic of the Field objects returned by the fields method.
275
276 my @names = $constraint->field_names;
277
278=cut
279
280 my $self = shift;
281 return wantarray ? @{ $self->{'fields'} } : $self->{'fields'};
282}
283
3c5de62a 284# ----------------------------------------------------------------------
752608d5 285sub match_type {
286
287=pod
288
289=head2 match_type
290
291Get or set the constraint's match_type. Only valid values are "full"
292or "partial."
293
294 my $match_type = $constraint->match_type('FULL');
295
296=cut
297
298 my $self = shift;
299
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;
304 }
305
306 return $self->{'match_type'} || '';
307}
308
309# ----------------------------------------------------------------------
3c5de62a 310sub name {
311
312=pod
313
314=head2 name
315
316Get or set the constraint's name.
317
318 my $name = $constraint->name('foo');
319
320=cut
321
322 my $self = shift;
695c2da2 323 my $arg = shift || '';
324 $self->{'name'} = $arg if $arg;
3c5de62a 325 return $self->{'name'} || '';
326}
327
328# ----------------------------------------------------------------------
dedb8f3b 329sub options {
330
331=pod
332
333=head2 options
334
335Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
336Returns an array or array reference.
337
338 $constraint->options('NORELY');
339 my @options = $constraint->options;
340
341=cut
342
343 my $self = shift;
344 my $options = parse_list_arg( @_ );
345
346 push @{ $self->{'options'} }, @$options;
347
348 if ( ref $self->{'options'} ) {
349 return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
350 }
351 else {
352 return wantarray ? () : [];
353 }
354}
355
356
357# ----------------------------------------------------------------------
43b9dc7a 358sub on_delete {
359
360=pod
361
362=head2 on_delete
363
364Get or set the constraint's "on delete" action.
365
366 my $action = $constraint->on_delete('cascade');
367
368=cut
369
370 my $self = shift;
371
372 if ( my $arg = shift ) {
373 # validate $arg?
374 $self->{'on_delete'} = $arg;
375 }
376
377 return $self->{'on_delete'} || '';
378}
379
380# ----------------------------------------------------------------------
381sub on_update {
382
383=pod
384
385=head2 on_update
386
387Get or set the constraint's "on update" action.
388
389 my $action = $constraint->on_update('no action');
390
391=cut
392
393 my $self = shift;
394
395 if ( my $arg = shift ) {
396 # validate $arg?
397 $self->{'on_update'} = $arg;
398 }
399
400 return $self->{'on_update'} || '';
401}
402
403# ----------------------------------------------------------------------
404sub reference_fields {
405
406=pod
407
408=head2 reference_fields
409
410Gets and set the fields in the referred table. Accepts a string, list or
411arrayref; returns an array or array reference.
412
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 ] );
418
419 my @reference_fields = $constraint->reference_fields;
420
421=cut
422
423 my $self = shift;
752608d5 424 my $fields = parse_list_arg( @_ );
43b9dc7a 425
426 if ( @$fields ) {
427 $self->{'reference_fields'} = $fields;
428 }
429
2d034ab4 430 # Nothing set so try and derive it from the other constraint data
43b9dc7a 431 unless ( ref $self->{'reference_fields'} ) {
2d034ab4 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'");
437
438 if ( my $constraint = $ref_table->primary_key ) {
439 $self->{'reference_fields'} = [ $constraint->fields ];
440 }
441 else {
442 $self->error(
443 'No reference fields defined and cannot find primary key in ',
444 "reference table '$ref_table_name'"
445 );
446 }
43b9dc7a 447 }
2d034ab4 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.
43b9dc7a 450 }
451
452 if ( ref $self->{'reference_fields'} ) {
453 return wantarray
2d034ab4 454 ? @{ $self->{'reference_fields'} }
43b9dc7a 455 : $self->{'reference_fields'};
456 }
457 else {
458 return wantarray ? () : [];
459 }
460}
461
462# ----------------------------------------------------------------------
463sub reference_table {
464
465=pod
466
467=head2 reference_table
468
469Get or set the table referred to by the constraint.
470
471 my $reference_table = $constraint->reference_table('foo');
472
473=cut
474
475 my $self = shift;
476 $self->{'reference_table'} = shift if @_;
477 return $self->{'reference_table'} || '';
478}
479
3c5de62a 480# ----------------------------------------------------------------------
43b9dc7a 481sub table {
3c5de62a 482
483=pod
484
43b9dc7a 485=head2 table
3c5de62a 486
2d034ab4 487Get or set the constraint's table object.
3c5de62a 488
43b9dc7a 489 my $table = $field->table;
3c5de62a 490
491=cut
492
493 my $self = shift;
43b9dc7a 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;
498 }
499
500 return $self->{'table'};
501}
502
503# ----------------------------------------------------------------------
dedb8f3b 504sub type {
43b9dc7a 505
506=pod
507
dedb8f3b 508=head2 type
43b9dc7a 509
dedb8f3b 510Get or set the constraint's type.
43b9dc7a 511
dedb8f3b 512 my $type = $constraint->type( PRIMARY_KEY );
43b9dc7a 513
514=cut
515
dedb8f3b 516 my $self = shift;
43b9dc7a 517
dedb8f3b 518 if ( my $type = uc shift ) {
519 $type =~ s/_/ /g;
520 return $self->error("Invalid constraint type: $type")
695c2da2 521 unless $VALID_CONSTRAINT_TYPE{ $type };
dedb8f3b 522 $self->{'type'} = $type;
43b9dc7a 523 }
3c5de62a 524
dedb8f3b 525 return $self->{'type'} || '';
526}
752608d5 527# ----------------------------------------------------------------------
528sub DESTROY {
529 my $self = shift;
530 undef $self->{'table'}; # destroy cyclical reference
531}
532
3c5de62a 5331;
534
535# ----------------------------------------------------------------------
536
537=pod
538
539=head1 AUTHOR
540
6606c4c6 541Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
3c5de62a 542
543=cut