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