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