Commit | Line | Data |
3c5de62a |
1 | package SQL::Translator::Schema::Constraint; |
2 | |
3 | # ---------------------------------------------------------------------- |
aa3a9517 |
4 | # $Id: Constraint.pm,v 1.7 2003-06-27 16:47:40 kycl4rk Exp $ |
3c5de62a |
5 | # ---------------------------------------------------------------------- |
6 | # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org> |
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 | |
27 | SQL::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 | |
40 | C<SQL::Translator::Schema::Constraint> is the constraint object. |
41 | |
42 | =head1 METHODS |
43 | |
44 | =cut |
45 | |
46 | use strict; |
47 | use Class::Base; |
43b9dc7a |
48 | use SQL::Translator::Schema::Constants; |
752608d5 |
49 | use SQL::Translator::Utils 'parse_list_arg'; |
3c5de62a |
50 | |
51 | use base 'Class::Base'; |
52 | use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT); |
53 | |
aa3a9517 |
54 | $VERSION = sprintf "%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/; |
3c5de62a |
55 | |
695c2da2 |
56 | my %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 | # ---------------------------------------------------------------------- |
65 | sub init { |
66 | |
67 | =pod |
68 | |
69 | =head2 new |
70 | |
71 | Object 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 |
78 | reference_fields => 'phone_id', # referenced table |
79 | reference_table => 'phone', # referenced fields |
3c5de62a |
80 | match_type => 'full', # how to match |
81 | on_delete_do => 'cascade', # what to do on deletes |
82 | on_update_do => '', # what to do on updates |
83 | ); |
84 | |
85 | =cut |
86 | |
87 | my ( $self, $config ) = @_; |
752608d5 |
88 | my @fields = qw[ |
89 | table name type fields reference_fields reference_table |
90 | match_type on_delete on_update |
91 | ]; |
3c5de62a |
92 | |
93 | for my $arg ( @fields ) { |
94 | next unless $config->{ $arg }; |
695c2da2 |
95 | defined $self->$arg( $config->{ $arg } ) or return; |
3c5de62a |
96 | } |
97 | |
98 | return $self; |
99 | } |
100 | |
101 | # ---------------------------------------------------------------------- |
43b9dc7a |
102 | sub deferrable { |
103 | |
104 | =pod |
105 | |
106 | =head2 deferrable |
107 | |
108 | Get or set the whether the constraint is deferrable. If not defined, |
109 | then returns "1." The argument is evaluated by Perl for True or |
110 | False, so the following are eqivalent: |
111 | |
112 | $deferrable = $field->deferrable(0); |
113 | $deferrable = $field->deferrable(''); |
114 | $deferrable = $field->deferrable('0'); |
115 | |
116 | =cut |
117 | |
118 | my ( $self, $arg ) = @_; |
119 | |
120 | if ( defined $arg ) { |
121 | $self->{'deferrable'} = $arg ? 1 : 0; |
122 | } |
123 | |
124 | return defined $self->{'deferrable'} ? $self->{'deferrable'} : 1; |
125 | } |
126 | |
127 | # ---------------------------------------------------------------------- |
128 | sub expression { |
129 | |
130 | =pod |
131 | |
132 | =head2 expression |
133 | |
134 | Gets and set the expression used in a CHECK constraint. |
135 | |
136 | my $expression = $constraint->expression('...'); |
137 | |
138 | =cut |
139 | |
140 | my $self = shift; |
141 | |
142 | if ( my $arg = shift ) { |
143 | # check arg here? |
144 | $self->{'expression'} = $arg; |
145 | } |
146 | |
147 | return $self->{'expression'} || ''; |
148 | } |
149 | |
150 | # ---------------------------------------------------------------------- |
151 | sub is_valid { |
152 | |
153 | =pod |
154 | |
155 | =head2 is_valid |
156 | |
157 | Determine whether the constraint is valid or not. |
158 | |
159 | my $ok = $constraint->is_valid; |
160 | |
161 | =cut |
162 | |
163 | my $self = shift; |
164 | my $type = $self->type or return $self->error('No type'); |
165 | my $table = $self->table or return $self->error('No table'); |
166 | my @fields = $self->fields or return $self->error('No fields'); |
167 | my $table_name = $table->name or return $self->error('No table name'); |
168 | |
169 | for my $f ( @fields ) { |
170 | next if $table->get_field( $f ); |
171 | return $self->error( |
172 | "Constraint references non-existent field '$f' ", |
173 | "in table '$table_name'" |
174 | ); |
175 | } |
176 | |
177 | my $schema = $table->schema or return $self->error( |
178 | 'Table ', $table->name, ' has no schema object' |
179 | ); |
180 | |
181 | if ( $type eq FOREIGN_KEY ) { |
182 | return $self->error('Only one field allowed for foreign key') |
183 | if scalar @fields > 1; |
184 | |
185 | my $ref_table_name = $self->reference_table or |
186 | return $self->error('No reference table'); |
187 | |
188 | my $ref_table = $schema->get_table( $ref_table_name ) or |
189 | return $self->error("No table named '$ref_table_name' in schema"); |
190 | |
191 | my @ref_fields = $self->reference_fields or return; |
192 | |
193 | return $self->error('Only one field allowed for foreign key reference') |
194 | if scalar @ref_fields > 1; |
195 | |
196 | for my $ref_field ( @ref_fields ) { |
197 | next if $ref_table->get_field( $ref_field ); |
198 | return $self->error( |
199 | "Constraint from field(s) ", |
200 | join(', ', map {qq['$table_name.$_']} @fields), |
201 | " to non-existent field '$ref_table_name.$ref_field'" |
202 | ); |
203 | } |
204 | } |
205 | elsif ( $type eq CHECK_C ) { |
206 | return $self->error('No expression for CHECK') unless |
207 | $self->expression; |
208 | } |
209 | |
210 | return 1; |
211 | } |
212 | |
213 | # ---------------------------------------------------------------------- |
3c5de62a |
214 | sub fields { |
215 | |
216 | =pod |
217 | |
218 | =head2 fields |
219 | |
43b9dc7a |
220 | Gets and set the fields the constraint is on. Accepts a string, list or |
221 | arrayref; returns an array or array reference. Will unique the field |
222 | names and keep them in order by the first occurrence of a field name. |
223 | |
224 | $constraint->fields('id'); |
225 | $constraint->fields('id', 'name'); |
226 | $constraint->fields( 'id, name' ); |
227 | $constraint->fields( [ 'id', 'name' ] ); |
228 | $constraint->fields( qw[ id name ] ); |
3c5de62a |
229 | |
43b9dc7a |
230 | my @fields = $constraint->fields; |
3c5de62a |
231 | |
232 | =cut |
233 | |
234 | my $self = shift; |
752608d5 |
235 | my $fields = parse_list_arg( @_ ); |
3c5de62a |
236 | |
237 | if ( @$fields ) { |
43b9dc7a |
238 | my ( %unique, @unique ); |
239 | for my $f ( @$fields ) { |
240 | next if $unique{ $f }; |
241 | $unique{ $f } = 1; |
242 | push @unique, $f; |
243 | } |
244 | |
245 | $self->{'fields'} = \@unique; |
3c5de62a |
246 | } |
247 | |
248 | return wantarray ? @{ $self->{'fields'} || [] } : $self->{'fields'}; |
249 | } |
250 | |
251 | # ---------------------------------------------------------------------- |
752608d5 |
252 | sub match_type { |
253 | |
254 | =pod |
255 | |
256 | =head2 match_type |
257 | |
258 | Get or set the constraint's match_type. Only valid values are "full" |
259 | or "partial." |
260 | |
261 | my $match_type = $constraint->match_type('FULL'); |
262 | |
263 | =cut |
264 | |
265 | my $self = shift; |
266 | |
267 | if ( my $arg = lc shift ) { |
268 | return $self->error("Invalid match type: $arg") |
269 | unless $arg eq 'full' || $arg eq 'partial'; |
270 | $self->{'match_type'} = $arg; |
271 | } |
272 | |
273 | return $self->{'match_type'} || ''; |
274 | } |
275 | |
276 | # ---------------------------------------------------------------------- |
3c5de62a |
277 | sub name { |
278 | |
279 | =pod |
280 | |
281 | =head2 name |
282 | |
283 | Get or set the constraint's name. |
284 | |
285 | my $name = $constraint->name('foo'); |
286 | |
287 | =cut |
288 | |
289 | my $self = shift; |
695c2da2 |
290 | my $arg = shift || ''; |
291 | $self->{'name'} = $arg if $arg; |
3c5de62a |
292 | return $self->{'name'} || ''; |
293 | } |
294 | |
295 | # ---------------------------------------------------------------------- |
dedb8f3b |
296 | sub options { |
297 | |
298 | =pod |
299 | |
300 | =head2 options |
301 | |
302 | Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE"). |
303 | Returns an array or array reference. |
304 | |
305 | $constraint->options('NORELY'); |
306 | my @options = $constraint->options; |
307 | |
308 | =cut |
309 | |
310 | my $self = shift; |
311 | my $options = parse_list_arg( @_ ); |
312 | |
313 | push @{ $self->{'options'} }, @$options; |
314 | |
315 | if ( ref $self->{'options'} ) { |
316 | return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'}; |
317 | } |
318 | else { |
319 | return wantarray ? () : []; |
320 | } |
321 | } |
322 | |
323 | |
324 | # ---------------------------------------------------------------------- |
43b9dc7a |
325 | sub on_delete { |
326 | |
327 | =pod |
328 | |
329 | =head2 on_delete |
330 | |
331 | Get or set the constraint's "on delete" action. |
332 | |
333 | my $action = $constraint->on_delete('cascade'); |
334 | |
335 | =cut |
336 | |
337 | my $self = shift; |
338 | |
339 | if ( my $arg = shift ) { |
340 | # validate $arg? |
341 | $self->{'on_delete'} = $arg; |
342 | } |
343 | |
344 | return $self->{'on_delete'} || ''; |
345 | } |
346 | |
347 | # ---------------------------------------------------------------------- |
348 | sub on_update { |
349 | |
350 | =pod |
351 | |
352 | =head2 on_update |
353 | |
354 | Get or set the constraint's "on update" action. |
355 | |
356 | my $action = $constraint->on_update('no action'); |
357 | |
358 | =cut |
359 | |
360 | my $self = shift; |
361 | |
362 | if ( my $arg = shift ) { |
363 | # validate $arg? |
364 | $self->{'on_update'} = $arg; |
365 | } |
366 | |
367 | return $self->{'on_update'} || ''; |
368 | } |
369 | |
370 | # ---------------------------------------------------------------------- |
371 | sub reference_fields { |
372 | |
373 | =pod |
374 | |
375 | =head2 reference_fields |
376 | |
377 | Gets and set the fields in the referred table. Accepts a string, list or |
378 | arrayref; returns an array or array reference. |
379 | |
380 | $constraint->reference_fields('id'); |
381 | $constraint->reference_fields('id', 'name'); |
382 | $constraint->reference_fields( 'id, name' ); |
383 | $constraint->reference_fields( [ 'id', 'name' ] ); |
384 | $constraint->reference_fields( qw[ id name ] ); |
385 | |
386 | my @reference_fields = $constraint->reference_fields; |
387 | |
388 | =cut |
389 | |
390 | my $self = shift; |
752608d5 |
391 | my $fields = parse_list_arg( @_ ); |
43b9dc7a |
392 | |
393 | if ( @$fields ) { |
394 | $self->{'reference_fields'} = $fields; |
395 | } |
396 | |
397 | unless ( ref $self->{'reference_fields'} ) { |
398 | my $table = $self->table or return $self->error('No table'); |
399 | my $schema = $table->schema or return $self->error('No schema'); |
400 | my $ref_table_name = $self->reference_table or |
401 | return $self->error('No table'); |
402 | my $ref_table = $schema->get_table( $ref_table_name ) or |
403 | return $self->error("Can't find table '$ref_table_name'"); |
404 | |
405 | if ( my $constraint = $ref_table->primary_key ) { |
406 | $self->{'reference_fields'} = [ $constraint->fields ]; |
407 | } |
408 | else { |
409 | $self->error( |
410 | 'No reference fields defined and cannot find primary key in ', |
411 | "reference table '$ref_table_name'" |
412 | ); |
413 | } |
414 | } |
415 | |
416 | if ( ref $self->{'reference_fields'} ) { |
417 | return wantarray |
418 | ? @{ $self->{'reference_fields'} || [] } |
419 | : $self->{'reference_fields'}; |
420 | } |
421 | else { |
422 | return wantarray ? () : []; |
423 | } |
424 | } |
425 | |
426 | # ---------------------------------------------------------------------- |
427 | sub reference_table { |
428 | |
429 | =pod |
430 | |
431 | =head2 reference_table |
432 | |
433 | Get or set the table referred to by the constraint. |
434 | |
435 | my $reference_table = $constraint->reference_table('foo'); |
436 | |
437 | =cut |
438 | |
439 | my $self = shift; |
440 | $self->{'reference_table'} = shift if @_; |
441 | return $self->{'reference_table'} || ''; |
442 | } |
443 | |
3c5de62a |
444 | # ---------------------------------------------------------------------- |
43b9dc7a |
445 | sub table { |
3c5de62a |
446 | |
447 | =pod |
448 | |
43b9dc7a |
449 | =head2 table |
3c5de62a |
450 | |
43b9dc7a |
451 | Get or set the field's table object. |
3c5de62a |
452 | |
43b9dc7a |
453 | my $table = $field->table; |
3c5de62a |
454 | |
455 | =cut |
456 | |
457 | my $self = shift; |
43b9dc7a |
458 | if ( my $arg = shift ) { |
459 | return $self->error('Not a table object') unless |
460 | UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' ); |
461 | $self->{'table'} = $arg; |
462 | } |
463 | |
464 | return $self->{'table'}; |
465 | } |
466 | |
467 | # ---------------------------------------------------------------------- |
dedb8f3b |
468 | sub type { |
43b9dc7a |
469 | |
470 | =pod |
471 | |
dedb8f3b |
472 | =head2 type |
43b9dc7a |
473 | |
dedb8f3b |
474 | Get or set the constraint's type. |
43b9dc7a |
475 | |
dedb8f3b |
476 | my $type = $constraint->type( PRIMARY_KEY ); |
43b9dc7a |
477 | |
478 | =cut |
479 | |
dedb8f3b |
480 | my $self = shift; |
43b9dc7a |
481 | |
dedb8f3b |
482 | if ( my $type = uc shift ) { |
483 | $type =~ s/_/ /g; |
484 | return $self->error("Invalid constraint type: $type") |
695c2da2 |
485 | unless $VALID_CONSTRAINT_TYPE{ $type }; |
dedb8f3b |
486 | $self->{'type'} = $type; |
43b9dc7a |
487 | } |
3c5de62a |
488 | |
dedb8f3b |
489 | return $self->{'type'} || ''; |
490 | } |
752608d5 |
491 | # ---------------------------------------------------------------------- |
492 | sub DESTROY { |
493 | my $self = shift; |
494 | undef $self->{'table'}; # destroy cyclical reference |
495 | } |
496 | |
3c5de62a |
497 | 1; |
498 | |
499 | # ---------------------------------------------------------------------- |
500 | |
501 | =pod |
502 | |
503 | =head1 AUTHOR |
504 | |
505 | Ken Y. Clark E<lt>kclark@cpan.orgE<gt> |
506 | |
507 | =cut |