Commit | Line | Data |
3c5de62a |
1 | package SQL::Translator::Schema::Constraint; |
2 | |
3c5de62a |
3 | =pod |
4 | |
5 | =head1 NAME |
6 | |
7 | SQL::Translator::Schema::Constraint - SQL::Translator constraint object |
8 | |
9 | =head1 SYNOPSIS |
10 | |
11 | use SQL::Translator::Schema::Constraint; |
12 | my $constraint = SQL::Translator::Schema::Constraint->new( |
13 | name => 'foo', |
14 | fields => [ id ], |
43b9dc7a |
15 | type => PRIMARY_KEY, |
3c5de62a |
16 | ); |
17 | |
18 | =head1 DESCRIPTION |
19 | |
20 | C<SQL::Translator::Schema::Constraint> is the constraint object. |
21 | |
22 | =head1 METHODS |
23 | |
24 | =cut |
25 | |
96a5759e |
26 | use Moo; |
43b9dc7a |
27 | use SQL::Translator::Schema::Constants; |
96a5759e |
28 | use SQL::Translator::Utils qw(parse_list_arg ex2err throw); |
29 | use SQL::Translator::Types qw(schema_obj); |
30 | use List::MoreUtils qw(uniq); |
31 | |
32 | with qw( |
46ad748f |
33 | SQL::Translator::Schema::Role::BuildArgs |
96a5759e |
34 | SQL::Translator::Schema::Role::Extra |
35 | SQL::Translator::Schema::Role::Error |
36 | SQL::Translator::Schema::Role::Compare |
37 | ); |
b6a880d1 |
38 | |
0c04c5a2 |
39 | our ( $TABLE_COUNT, $VIEW_COUNT ); |
da06ac74 |
40 | |
0c04c5a2 |
41 | our $VERSION = '1.59'; |
3c5de62a |
42 | |
695c2da2 |
43 | my %VALID_CONSTRAINT_TYPE = ( |
43b9dc7a |
44 | PRIMARY_KEY, 1, |
45 | UNIQUE, 1, |
46 | CHECK_C, 1, |
47 | FOREIGN_KEY, 1, |
695c2da2 |
48 | NOT_NULL, 1, |
49 | ); |
3c5de62a |
50 | |
3c5de62a |
51 | =head2 new |
52 | |
53 | Object constructor. |
54 | |
55 | my $schema = SQL::Translator::Schema::Constraint->new( |
dedb8f3b |
56 | table => $table, # table to which it belongs |
3c5de62a |
57 | type => 'foreign_key', # type of table constraint |
dedb8f3b |
58 | name => 'fk_phone_id', # name of the constraint |
59 | fields => 'phone_id', # field in the referring table |
65157eda |
60 | reference_fields => 'phone_id', # referenced field |
61 | reference_table => 'phone', # referenced table |
3c5de62a |
62 | match_type => 'full', # how to match |
2d034ab4 |
63 | on_delete => 'cascade', # what to do on deletes |
64 | on_update => '', # what to do on updates |
3c5de62a |
65 | ); |
66 | |
67 | =cut |
68 | |
96a5759e |
69 | # Override to remove empty arrays from args. |
70 | # t/14postgres-parser breaks without this. |
71 | around BUILDARGS => sub { |
72 | my $orig = shift; |
9371be50 |
73 | my $self = shift; |
96a5759e |
74 | my $args = $self->$orig(@_); |
43b9dc7a |
75 | |
96a5759e |
76 | foreach my $arg (keys %{$args}) { |
46ad748f |
77 | delete $args->{$arg} if ref($args->{$arg}) eq "ARRAY" && !@{$args->{$arg}}; |
96a5759e |
78 | } |
79 | if (exists $args->{fields}) { |
80 | $args->{field_names} = delete $args->{fields}; |
81 | } |
82 | return $args; |
83 | }; |
43b9dc7a |
84 | |
85 | =head2 deferrable |
86 | |
2d034ab4 |
87 | Get or set whether the constraint is deferrable. If not defined, |
43b9dc7a |
88 | then returns "1." The argument is evaluated by Perl for True or |
89 | False, so the following are eqivalent: |
90 | |
91 | $deferrable = $field->deferrable(0); |
92 | $deferrable = $field->deferrable(''); |
93 | $deferrable = $field->deferrable('0'); |
94 | |
95 | =cut |
96 | |
96a5759e |
97 | has deferrable => ( is => 'rw', coerce => sub { $_[0] ? 1 : 0 }, default => sub { 1 } ); |
43b9dc7a |
98 | |
99 | =head2 expression |
100 | |
101 | Gets and set the expression used in a CHECK constraint. |
102 | |
103 | my $expression = $constraint->expression('...'); |
104 | |
105 | =cut |
106 | |
96a5759e |
107 | has expression => ( is => 'rw', default => sub { '' } ); |
43b9dc7a |
108 | |
96a5759e |
109 | around expression => sub { |
110 | my ($orig, $self, $arg) = @_; |
111 | $self->$orig($arg || ()); |
112 | }; |
43b9dc7a |
113 | |
43b9dc7a |
114 | sub is_valid { |
115 | |
116 | =pod |
117 | |
118 | =head2 is_valid |
119 | |
120 | Determine whether the constraint is valid or not. |
121 | |
122 | my $ok = $constraint->is_valid; |
123 | |
124 | =cut |
125 | |
126 | my $self = shift; |
127 | my $type = $self->type or return $self->error('No type'); |
128 | my $table = $self->table or return $self->error('No table'); |
129 | my @fields = $self->fields or return $self->error('No fields'); |
130 | my $table_name = $table->name or return $self->error('No table name'); |
131 | |
132 | for my $f ( @fields ) { |
133 | next if $table->get_field( $f ); |
134 | return $self->error( |
135 | "Constraint references non-existent field '$f' ", |
136 | "in table '$table_name'" |
137 | ); |
138 | } |
139 | |
140 | my $schema = $table->schema or return $self->error( |
141 | 'Table ', $table->name, ' has no schema object' |
142 | ); |
143 | |
144 | if ( $type eq FOREIGN_KEY ) { |
145 | return $self->error('Only one field allowed for foreign key') |
146 | if scalar @fields > 1; |
147 | |
ea93df61 |
148 | my $ref_table_name = $self->reference_table or |
43b9dc7a |
149 | return $self->error('No reference table'); |
150 | |
151 | my $ref_table = $schema->get_table( $ref_table_name ) or |
152 | return $self->error("No table named '$ref_table_name' in schema"); |
153 | |
154 | my @ref_fields = $self->reference_fields or return; |
155 | |
156 | return $self->error('Only one field allowed for foreign key reference') |
157 | if scalar @ref_fields > 1; |
158 | |
159 | for my $ref_field ( @ref_fields ) { |
160 | next if $ref_table->get_field( $ref_field ); |
161 | return $self->error( |
96a5759e |
162 | "Constraint from field(s) ". |
163 | join(', ', map {qq['$table_name.$_']} @fields). |
43b9dc7a |
164 | " to non-existent field '$ref_table_name.$ref_field'" |
165 | ); |
166 | } |
167 | } |
168 | elsif ( $type eq CHECK_C ) { |
ea93df61 |
169 | return $self->error('No expression for CHECK') unless |
43b9dc7a |
170 | $self->expression; |
171 | } |
172 | |
173 | return 1; |
174 | } |
175 | |
3c5de62a |
176 | =head2 fields |
177 | |
43b9dc7a |
178 | Gets and set the fields the constraint is on. Accepts a string, list or |
179 | arrayref; returns an array or array reference. Will unique the field |
180 | names and keep them in order by the first occurrence of a field name. |
181 | |
ac095e5e |
182 | The fields are returned as Field objects if they exist or as plain |
183 | names if not. (If you just want the names and want to avoid the Field's overload |
184 | magic use L<field_names>). |
185 | |
186 | Returns undef or an empty list if the constraint has no fields set. |
187 | |
43b9dc7a |
188 | $constraint->fields('id'); |
189 | $constraint->fields('id', 'name'); |
190 | $constraint->fields( 'id, name' ); |
191 | $constraint->fields( [ 'id', 'name' ] ); |
192 | $constraint->fields( qw[ id name ] ); |
3c5de62a |
193 | |
43b9dc7a |
194 | my @fields = $constraint->fields; |
3c5de62a |
195 | |
196 | =cut |
197 | |
96a5759e |
198 | sub fields { |
199 | my $self = shift; |
200 | my $table = $self->table; |
201 | my @tables = map { $table->get_field($_) || $_ } @{$self->field_names(@_) || []}; |
202 | return wantarray ? @tables |
203 | : @tables ? \@tables |
204 | : undef; |
3c5de62a |
205 | } |
206 | |
ac095e5e |
207 | =head2 field_names |
208 | |
209 | Read-only method to return a list or array ref of the field names. Returns undef |
10f70490 |
210 | or an empty list if the constraint has no fields set. Useful if you want to |
ac095e5e |
211 | avoid the overload magic of the Field objects returned by the fields method. |
212 | |
213 | my @names = $constraint->field_names; |
214 | |
215 | =cut |
216 | |
96a5759e |
217 | has field_names => ( |
218 | is => 'rw', |
219 | default => sub { [] }, |
220 | coerce => sub { [uniq @{parse_list_arg($_[0])}] }, |
221 | ); |
ac095e5e |
222 | |
96a5759e |
223 | around field_names => sub { |
224 | my $orig = shift; |
225 | my $self = shift; |
226 | my $fields = parse_list_arg( @_ ); |
227 | $self->$orig($fields) if @$fields; |
752608d5 |
228 | |
96a5759e |
229 | $fields = $self->$orig; |
230 | return wantarray ? @{$fields} |
231 | : @{$fields} ? $fields |
232 | : undef; |
233 | }; |
752608d5 |
234 | |
235 | =head2 match_type |
236 | |
237 | Get or set the constraint's match_type. Only valid values are "full" |
840447a5 |
238 | "partial" and "simple" |
752608d5 |
239 | |
240 | my $match_type = $constraint->match_type('FULL'); |
241 | |
242 | =cut |
243 | |
96a5759e |
244 | has match_type => ( |
245 | is => 'rw', |
246 | default => sub { '' }, |
247 | coerce => sub { lc $_[0] }, |
248 | isa => sub { |
249 | my $arg = $_[0]; |
250 | throw("Invalid match type: $arg") |
251 | if $arg && !($arg eq 'full' || $arg eq 'partial' || $arg eq 'simple'); |
252 | }, |
253 | ); |
752608d5 |
254 | |
96a5759e |
255 | around match_type => \&ex2err; |
3c5de62a |
256 | |
257 | =head2 name |
258 | |
259 | Get or set the constraint's name. |
260 | |
261 | my $name = $constraint->name('foo'); |
262 | |
263 | =cut |
264 | |
96a5759e |
265 | has name => ( is => 'rw', default => sub { '' } ); |
3c5de62a |
266 | |
96a5759e |
267 | around name => sub { |
268 | my ($orig, $self, $arg) = @_; |
269 | $self->$orig($arg || ()); |
270 | }; |
dedb8f3b |
271 | |
272 | =head2 options |
273 | |
ea93df61 |
274 | Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE"). |
dedb8f3b |
275 | Returns an array or array reference. |
276 | |
277 | $constraint->options('NORELY'); |
278 | my @options = $constraint->options; |
279 | |
280 | =cut |
281 | |
96a5759e |
282 | has options => ( is => 'rw', coerce => \&parse_list_arg, default => sub { [] } ); |
283 | |
284 | around options => sub { |
285 | my $orig = shift; |
dedb8f3b |
286 | my $self = shift; |
287 | my $options = parse_list_arg( @_ ); |
288 | |
96a5759e |
289 | push @{ $self->$orig }, @$options; |
43b9dc7a |
290 | |
96a5759e |
291 | return wantarray ? @{ $self->$orig } : $self->$orig; |
292 | }; |
43b9dc7a |
293 | |
294 | =head2 on_delete |
295 | |
296 | Get or set the constraint's "on delete" action. |
297 | |
298 | my $action = $constraint->on_delete('cascade'); |
299 | |
300 | =cut |
301 | |
96a5759e |
302 | has on_delete => ( is => 'rw', default => sub { '' } ); |
43b9dc7a |
303 | |
96a5759e |
304 | around on_delete => sub { |
305 | my ($orig, $self, $arg) = @_; |
306 | $self->$orig($arg || ()); |
307 | }; |
43b9dc7a |
308 | |
309 | =head2 on_update |
310 | |
311 | Get or set the constraint's "on update" action. |
312 | |
313 | my $action = $constraint->on_update('no action'); |
314 | |
315 | =cut |
316 | |
96a5759e |
317 | has on_update => ( is => 'rw', default => sub { '' } ); |
43b9dc7a |
318 | |
96a5759e |
319 | around on_update => sub { |
320 | my ($orig, $self, $arg) = @_; |
321 | $self->$orig($arg || ()); |
322 | }; |
43b9dc7a |
323 | |
324 | =head2 reference_fields |
325 | |
326 | Gets and set the fields in the referred table. Accepts a string, list or |
327 | arrayref; returns an array or array reference. |
328 | |
329 | $constraint->reference_fields('id'); |
330 | $constraint->reference_fields('id', 'name'); |
331 | $constraint->reference_fields( 'id, name' ); |
332 | $constraint->reference_fields( [ 'id', 'name' ] ); |
333 | $constraint->reference_fields( qw[ id name ] ); |
334 | |
335 | my @reference_fields = $constraint->reference_fields; |
336 | |
337 | =cut |
338 | |
96a5759e |
339 | has reference_fields => ( |
340 | is => 'rw', |
341 | coerce => sub { [uniq @{parse_list_arg($_[0])}] }, |
342 | builder => 1, |
343 | lazy => 1, |
344 | ); |
345 | |
346 | around reference_fields => sub { |
347 | my $orig = shift; |
43b9dc7a |
348 | my $self = shift; |
752608d5 |
349 | my $fields = parse_list_arg( @_ ); |
96a5759e |
350 | $self->$orig($fields) if @$fields; |
43b9dc7a |
351 | |
96a5759e |
352 | $fields = ex2err($orig, $self) or return; |
353 | return wantarray ? @{$fields} : $fields |
354 | }; |
43b9dc7a |
355 | |
96a5759e |
356 | sub _build_reference_fields { |
357 | my ($self) = @_; |
43b9dc7a |
358 | |
96a5759e |
359 | my $table = $self->table or throw('No table'); |
360 | my $schema = $table->schema or throw('No schema'); |
361 | if ( my $ref_table_name = $self->reference_table ) { |
362 | my $ref_table = $schema->get_table( $ref_table_name ) or |
363 | throw("Can't find table '$ref_table_name'"); |
364 | |
365 | if ( my $constraint = $ref_table->primary_key ) { |
366 | return [ $constraint->fields ]; |
367 | } |
368 | else { |
369 | throw( |
370 | 'No reference fields defined and cannot find primary key in ', |
371 | "reference table '$ref_table_name'" |
372 | ); |
373 | } |
43b9dc7a |
374 | } |
375 | } |
376 | |
43b9dc7a |
377 | =head2 reference_table |
378 | |
379 | Get or set the table referred to by the constraint. |
380 | |
381 | my $reference_table = $constraint->reference_table('foo'); |
382 | |
383 | =cut |
384 | |
96a5759e |
385 | has reference_table => ( is => 'rw', default => sub { '' } ); |
3c5de62a |
386 | |
43b9dc7a |
387 | =head2 table |
3c5de62a |
388 | |
2d034ab4 |
389 | Get or set the constraint's table object. |
3c5de62a |
390 | |
43b9dc7a |
391 | my $table = $field->table; |
3c5de62a |
392 | |
393 | =cut |
394 | |
96a5759e |
395 | has table => ( is => 'rw', isa => schema_obj('Table') ); |
43b9dc7a |
396 | |
96a5759e |
397 | around table => \&ex2err; |
43b9dc7a |
398 | |
dedb8f3b |
399 | =head2 type |
43b9dc7a |
400 | |
dedb8f3b |
401 | Get or set the constraint's type. |
43b9dc7a |
402 | |
dedb8f3b |
403 | my $type = $constraint->type( PRIMARY_KEY ); |
43b9dc7a |
404 | |
405 | =cut |
406 | |
96a5759e |
407 | has type => ( |
408 | is => 'rw', |
409 | default => sub { '' }, |
410 | isa => sub { |
411 | throw("Invalid constraint type: $_[0]") |
412 | if $_[0] && !$VALID_CONSTRAINT_TYPE{ $_[0] }; |
413 | }, |
414 | coerce => sub { (my $t = $_[0]) =~ s/_/ /g; uc $t }, |
415 | ); |
abf315bb |
416 | |
96a5759e |
417 | around type => \&ex2err; |
abf315bb |
418 | |
419 | =head2 equals |
420 | |
421 | Determines if this constraint is the same as another |
422 | |
423 | my $isIdentical = $constraint1->equals( $constraint2 ); |
424 | |
425 | =cut |
426 | |
96a5759e |
427 | around equals => sub { |
428 | my $orig = shift; |
abf315bb |
429 | my $self = shift; |
430 | my $other = shift; |
431 | my $case_insensitive = shift; |
d990d84b |
432 | my $ignore_constraint_names = shift; |
ea93df61 |
433 | |
96a5759e |
434 | return 0 unless $self->$orig($other); |
b8d24485 |
435 | return 0 unless $self->type eq $other->type; |
d990d84b |
436 | unless ($ignore_constraint_names) { |
437 | return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name; |
438 | } |
abf315bb |
439 | return 0 unless $self->deferrable eq $other->deferrable; |
4598b71c |
440 | #return 0 unless $self->is_valid eq $other->is_valid; |
abf315bb |
441 | return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name) |
ea93df61 |
442 | : $self->table->name eq $other->table->name; |
abf315bb |
443 | return 0 unless $self->expression eq $other->expression; |
ea93df61 |
444 | |
6a0f3000 |
445 | # Check fields, regardless of order |
ea93df61 |
446 | my %otherFields = (); # create a hash of the other fields |
6a0f3000 |
447 | foreach my $otherField ($other->fields) { |
ea93df61 |
448 | $otherField = uc($otherField) if $case_insensitive; |
449 | $otherFields{$otherField} = 1; |
6a0f3000 |
450 | } |
451 | foreach my $selfField ($self->fields) { # check for self fields in hash |
ea93df61 |
452 | $selfField = uc($selfField) if $case_insensitive; |
453 | return 0 unless $otherFields{$selfField}; |
454 | delete $otherFields{$selfField}; |
6a0f3000 |
455 | } |
456 | # Check all other fields were accounted for |
457 | return 0 unless keys %otherFields == 0; |
458 | |
459 | # Check reference fields, regardless of order |
ea93df61 |
460 | my %otherRefFields = (); # create a hash of the other reference fields |
6a0f3000 |
461 | foreach my $otherRefField ($other->reference_fields) { |
ea93df61 |
462 | $otherRefField = uc($otherRefField) if $case_insensitive; |
463 | $otherRefFields{$otherRefField} = 1; |
6a0f3000 |
464 | } |
465 | foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash |
ea93df61 |
466 | $selfRefField = uc($selfRefField) if $case_insensitive; |
467 | return 0 unless $otherRefFields{$selfRefField}; |
468 | delete $otherRefFields{$selfRefField}; |
6a0f3000 |
469 | } |
470 | # Check all other reference fields were accounted for |
471 | return 0 unless keys %otherRefFields == 0; |
472 | |
b8d24485 |
473 | return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table; |
abf315bb |
474 | return 0 unless $self->match_type eq $other->match_type; |
475 | return 0 unless $self->on_delete eq $other->on_delete; |
476 | return 0 unless $self->on_update eq $other->on_update; |
4598b71c |
477 | return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options); |
478 | return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra); |
abf315bb |
479 | return 1; |
96a5759e |
480 | }; |
abf315bb |
481 | |
752608d5 |
482 | sub DESTROY { |
483 | my $self = shift; |
484 | undef $self->{'table'}; # destroy cyclical reference |
485 | } |
486 | |
96a5759e |
487 | # Must come after all 'has' declarations |
488 | around new => \&ex2err; |
489 | |
3c5de62a |
490 | 1; |
491 | |
3c5de62a |
492 | =pod |
493 | |
494 | =head1 AUTHOR |
495 | |
c3b0b535 |
496 | Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>. |
3c5de62a |
497 | |
498 | =cut |