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