Clean up option parsing and identifier quoting in Producer::PostgreSQL
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Schema / Table.pm
CommitLineData
3c5de62a 1package SQL::Translator::Schema::Table;
2
3c5de62a 3=pod
4
5=head1 NAME
6
7SQL::Translator::Schema::Table - SQL::Translator table object
8
9=head1 SYNOPSIS
10
11 use SQL::Translator::Schema::Table;
0f3cc5c0 12 my $table = SQL::Translator::Schema::Table->new( name => 'foo' );
3c5de62a 13
6f2cf9ca 14=head1 DESCRIPTION
3c5de62a 15
16C<SQL::Translator::Schema::Table> is the table object.
17
18=head1 METHODS
19
20=cut
21
90097ddd 22use Moo;
02240029 23use SQL::Translator::Utils qw(parse_list_arg ex2err throw carp_ro);
558482f7 24use SQL::Translator::Types qw(schema_obj);
0fb58589 25use SQL::Translator::Role::ListAttr;
0f3cc5c0 26use SQL::Translator::Schema::Constants;
3c5de62a 27use SQL::Translator::Schema::Constraint;
28use SQL::Translator::Schema::Field;
29use SQL::Translator::Schema::Index;
807290c3 30
31use Carp::Clan '^SQL::Translator';
32use List::Util 'max';
68d75205 33use Sub::Quote qw(quote_sub);
3c5de62a 34
954ed12e 35extends 'SQL::Translator::Schema::Object';
b6a880d1 36
0c04c5a2 37our $VERSION = '1.59';
5342f5c1 38
65dd38c0 39# Stringify to our name, being careful not to pass any args through so we don't
40# accidentally set it to undef. We also have to tweak bool so the object is
41# still true when it doesn't have a name (which shouldn't happen!).
42use overload
43 '""' => sub { shift->name },
44 'bool' => sub { $_[0]->name || $_[0] },
45 fallback => 1,
46;
3c5de62a 47
3c5de62a 48=pod
49
50=head2 new
51
52Object constructor.
53
ea93df61 54 my $table = SQL::Translator::Schema::Table->new(
43b9dc7a 55 schema => $schema,
56 name => 'foo',
57 );
3c5de62a 58
3c5de62a 59=head2 add_constraint
60
ea93df61 61Add a constraint to the table. Returns the newly created
0f3cc5c0 62C<SQL::Translator::Schema::Constraint> object.
3c5de62a 63
870024f3 64 my $c1 = $table->add_constraint(
65 name => 'pk',
66 type => PRIMARY_KEY,
67 fields => [ 'foo_id' ],
3c5de62a 68 );
69
dfdb0568 70 my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
71 $c2 = $table->add_constraint( $constraint );
43b9dc7a 72
3c5de62a 73=cut
74
558482f7 75has _constraints => (
76 is => 'ro',
77 init_arg => undef,
68d75205 78 default => quote_sub(q{ +[] }),
558482f7 79 predicate => 1,
80 lazy => 1,
81);
82
83sub add_constraint {
43b9dc7a 84 my $self = shift;
85 my $constraint_class = 'SQL::Translator::Schema::Constraint';
86 my $constraint;
87
88 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
89 $constraint = shift;
90 $constraint->table( $self );
91 }
92 else {
93 my %args = @_;
94 $args{'table'} = $self;
ea93df61 95 $constraint = $constraint_class->new( \%args ) or
b1789409 96 return $self->error( $constraint_class->error );
43b9dc7a 97 }
98
dfdb0568 99 #
100 # If we're trying to add a PK when one is already defined,
101 # then just add the fields to the existing definition.
102 #
3dd9026c 103 my $ok = 1;
dfdb0568 104 my $pk = $self->primary_key;
105 if ( $pk && $constraint->type eq PRIMARY_KEY ) {
106 $self->primary_key( $constraint->fields );
b1789409 107 $pk->name($constraint->name) if $constraint->name;
ea93df61 108 my %extra = $constraint->extra;
b1789409 109 $pk->extra(%extra) if keys %extra;
dfdb0568 110 $constraint = $pk;
3dd9026c 111 $ok = 0;
dfdb0568 112 }
2ccf2299 113 elsif ( $constraint->type eq PRIMARY_KEY ) {
114 for my $fname ( $constraint->fields ) {
115 if ( my $f = $self->get_field( $fname ) ) {
116 $f->is_primary_key( 1 );
117 }
118 }
119 }
3dd9026c 120 #
ea93df61 121 # See if another constraint of the same type
be53b4c8 122 # covers the same fields. -- This doesn't work! ky
3dd9026c 123 #
be53b4c8 124# elsif ( $constraint->type ne CHECK_C ) {
125# my @field_names = $constraint->fields;
ea93df61 126# for my $c (
127# grep { $_->type eq $constraint->type }
128# $self->get_constraints
be53b4c8 129# ) {
130# my %fields = map { $_, 1 } $c->fields;
131# for my $field_name ( @field_names ) {
132# if ( $fields{ $field_name } ) {
133# $constraint = $c;
ea93df61 134# $ok = 0;
be53b4c8 135# last;
136# }
137# }
138# last unless $ok;
139# }
140# }
dfdb0568 141
142 if ( $ok ) {
558482f7 143 push @{ $self->_constraints }, $constraint;
dfdb0568 144 }
145
3c5de62a 146 return $constraint;
147}
148
650f87eb 149=head2 drop_constraint
150
151Remove a constraint from the table. Returns the constraint object if the index
152was found and removed, an error otherwise. The single parameter can be either
153an index name or an C<SQL::Translator::Schema::Constraint> object.
154
155 $table->drop_constraint('myconstraint');
156
157=cut
158
558482f7 159sub drop_constraint {
650f87eb 160 my $self = shift;
161 my $constraint_class = 'SQL::Translator::Schema::Constraint';
162 my $constraint_name;
163
164 if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
165 $constraint_name = shift->name;
166 }
167 else {
168 $constraint_name = shift;
169 }
170
558482f7 171 if ( ! ($self->_has_constraints && grep { $_->name eq $constraint_name } @ { $self->_constraints }) ) {
650f87eb 172 return $self->error(qq[Can't drop constraint: "$constraint_name" doesn't exist]);
173 }
174
558482f7 175 my @cs = @{ $self->_constraints };
650f87eb 176 my ($constraint_id) = grep { $cs[$_]->name eq $constraint_name } (0..$#cs);
558482f7 177 my $constraint = splice(@{$self->_constraints}, $constraint_id, 1);
650f87eb 178
179 return $constraint;
180}
181
3c5de62a 182=head2 add_index
183
0f3cc5c0 184Add an index to the table. Returns the newly created
185C<SQL::Translator::Schema::Index> object.
3c5de62a 186
870024f3 187 my $i1 = $table->add_index(
3c5de62a 188 name => 'name',
189 fields => [ 'name' ],
190 type => 'normal',
191 );
192
dfdb0568 193 my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
194 $i2 = $table->add_index( $index );
43b9dc7a 195
3c5de62a 196=cut
197
558482f7 198has _indices => (
199 is => 'ro',
200 init_arg => undef,
68d75205 201 default => quote_sub(q{ [] }),
558482f7 202 predicate => 1,
203 lazy => 1,
204);
205
206sub add_index {
43b9dc7a 207 my $self = shift;
208 my $index_class = 'SQL::Translator::Schema::Index';
209 my $index;
210
211 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
212 $index = shift;
213 $index->table( $self );
214 }
215 else {
216 my %args = @_;
217 $args{'table'} = $self;
ea93df61 218 $index = $index_class->new( \%args ) or return
43b9dc7a 219 $self->error( $index_class->error );
220 }
da5a1bae 221 foreach my $ex_index ($self->get_indices) {
222 return if ($ex_index->equals($index));
223 }
558482f7 224 push @{ $self->_indices }, $index;
3c5de62a 225 return $index;
226}
227
650f87eb 228=head2 drop_index
229
230Remove an index from the table. Returns the index object if the index was
231found and removed, an error otherwise. The single parameter can be either
232an index name of an C<SQL::Translator::Schema::Index> object.
233
234 $table->drop_index('myindex');
235
236=cut
237
558482f7 238sub drop_index {
650f87eb 239 my $self = shift;
240 my $index_class = 'SQL::Translator::Schema::Index';
241 my $index_name;
242
243 if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
244 $index_name = shift->name;
245 }
246 else {
247 $index_name = shift;
248 }
249
558482f7 250 if ( ! ($self->_has_indices && grep { $_->name eq $index_name } @{ $self->_indices }) ) {
650f87eb 251 return $self->error(qq[Can't drop index: "$index_name" doesn't exist]);
252 }
253
558482f7 254 my @is = @{ $self->_indices };
650f87eb 255 my ($index_id) = grep { $is[$_]->name eq $index_name } (0..$#is);
558482f7 256 my $index = splice(@{$self->_indices}, $index_id, 1);
650f87eb 257
258 return $index;
259}
260
3c5de62a 261=head2 add_field
262
43b9dc7a 263Add an field to the table. Returns the newly created
ea93df61 264C<SQL::Translator::Schema::Field> object. The "name" parameter is
265required. If you try to create a field with the same name as an
43b9dc7a 266existing field, you will get an error and the field will not be created.
3c5de62a 267
870024f3 268 my $f1 = $table->add_field(
0f3cc5c0 269 name => 'foo_id',
270 data_type => 'integer',
271 size => 11,
3c5de62a 272 );
273
ea93df61 274 my $f2 = SQL::Translator::Schema::Field->new(
275 name => 'name',
43b9dc7a 276 table => $table,
277 );
870024f3 278 $f2 = $table->add_field( $field2 ) or die $table->error;
43b9dc7a 279
3c5de62a 280=cut
281
558482f7 282has _fields => (
283 is => 'ro',
284 init_arg => undef,
68d75205 285 default => quote_sub(q{ +{} }),
558482f7 286 predicate => 1,
287 lazy => 1
288);
289
290sub add_field {
dfdb0568 291 my $self = shift;
43b9dc7a 292 my $field_class = 'SQL::Translator::Schema::Field';
293 my $field;
294
295 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
296 $field = shift;
297 $field->table( $self );
298 }
299 else {
300 my %args = @_;
301 $args{'table'} = $self;
ea93df61 302 $field = $field_class->new( \%args ) or return
43b9dc7a 303 $self->error( $field_class->error );
304 }
305
807290c3 306 my $existing_order = { map { $_->order => $_->name } $self->get_fields };
307
308 # supplied order, possible unordered assembly
309 if ( $field->order ) {
310 if($existing_order->{$field->order}) {
311 croak sprintf
312 "Requested order '%d' for column '%s' conflicts with already existing column '%s'",
313 $field->order,
314 $field->name,
315 $existing_order->{$field->order},
316 ;
317 }
318 }
319 else {
320 my $last_field_no = max(keys %$existing_order) || 0;
321 if ( $last_field_no != scalar keys %$existing_order ) {
322 croak sprintf
323 "Table '%s' field order incomplete - unable to auto-determine order for newly added field",
324 $self->name,
325 ;
326 }
327
328 $field->order( $last_field_no + 1 );
329 }
330
65dd38c0 331 # We know we have a name as the Field->new above errors if none given.
332 my $field_name = $field->name;
43b9dc7a 333
807290c3 334 if ( $self->get_field($field_name) ) {
a14ab50e 335 return $self->error(qq[Can't use field name "$field_name": field exists]);
43b9dc7a 336 }
337 else {
558482f7 338 $self->_fields->{ $field_name } = $field;
43b9dc7a 339 }
340
3c5de62a 341 return $field;
342}
282bf498 343
650f87eb 344=head2 drop_field
345
ea93df61 346Remove a field from the table. Returns the field object if the field was
347found and removed, an error otherwise. The single parameter can be either
650f87eb 348a field name or an C<SQL::Translator::Schema::Field> object.
349
350 $table->drop_field('myfield');
351
352=cut
353
558482f7 354sub drop_field {
650f87eb 355 my $self = shift;
356 my $field_class = 'SQL::Translator::Schema::Field';
357 my $field_name;
358
359 if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
360 $field_name = shift->name;
361 }
362 else {
363 $field_name = shift;
364 }
365 my %args = @_;
366 my $cascade = $args{'cascade'};
367
558482f7 368 if ( ! ($self->_has_fields && exists $self->_fields->{ $field_name } ) ) {
650f87eb 369 return $self->error(qq[Can't drop field: "$field_name" doesn't exists]);
370 }
371
558482f7 372 my $field = delete $self->_fields->{ $field_name };
650f87eb 373
374 if ( $cascade ) {
375 # Remove this field from all indices using it
376 foreach my $i ($self->get_indices()) {
377 my @fs = $i->fields();
378 @fs = grep { $_ ne $field->name } @fs;
379 $i->fields(@fs);
380 }
381
382 # Remove this field from all constraints using it
383 foreach my $c ($self->get_constraints()) {
384 my @cs = $c->fields();
385 @cs = grep { $_ ne $field->name } @cs;
386 $c->fields(@cs);
387 }
388 }
389
390 return $field;
391}
3c5de62a 392
88b8377e 393=head2 comments
394
ea93df61 395Get or set the comments on a table. May be called several times to
88b8377e 396set and it will accumulate the comments. Called in an array context,
397returns each comment individually; called in a scalar context, returns
398all the comments joined on newlines.
399
400 $table->comments('foo');
401 $table->comments('bar');
402 print join( ', ', $table->comments ); # prints "foo, bar"
403
404=cut
405
558482f7 406has comments => (
407 is => 'rw',
c804300c 408 coerce => quote_sub(q{ ref($_[0]) eq 'ARRAY' ? $_[0] : [$_[0]] }),
68d75205 409 default => quote_sub(q{ [] }),
558482f7 410);
411
412around comments => sub {
413 my $orig = shift;
eb3b8ae4 414 my $self = shift;
415 my @comments = ref $_[0] ? @{ $_[0] } : @_;
b891fb49 416
eb3b8ae4 417 for my $arg ( @comments ) {
b891fb49 418 $arg = $arg->[0] if ref $arg;
558482f7 419 push @{ $self->$orig }, $arg if defined $arg && $arg;
b891fb49 420 }
88b8377e 421
558482f7 422 @comments = @{$self->$orig};
423 return wantarray ? @comments
424 : @comments ? join( "\n", @comments )
425 : undef;
426};
0f3cc5c0 427
428=head2 get_constraints
429
430Returns all the constraint objects as an array or array reference.
431
432 my @constraints = $table->get_constraints;
433
434=cut
435
558482f7 436sub get_constraints {
0f3cc5c0 437 my $self = shift;
438
558482f7 439 if ( $self->_has_constraints ) {
ea93df61 440 return wantarray
558482f7 441 ? @{ $self->_constraints } : $self->_constraints;
0f3cc5c0 442 }
443 else {
444 $self->error('No constraints');
c5409185 445 return;
0f3cc5c0 446 }
447}
448
0f3cc5c0 449=head2 get_indices
3c5de62a 450
0f3cc5c0 451Returns all the index objects as an array or array reference.
3c5de62a 452
0f3cc5c0 453 my @indices = $table->get_indices;
3c5de62a 454
455=cut
456
558482f7 457sub get_indices {
3c5de62a 458 my $self = shift;
0f3cc5c0 459
558482f7 460 if ( $self->_has_indices ) {
ea93df61 461 return wantarray
558482f7 462 ? @{ $self->_indices }
463 : $self->_indices;
0f3cc5c0 464 }
465 else {
466 $self->error('No indices');
c5409185 467 return;
0f3cc5c0 468 }
469}
470
43b9dc7a 471=head2 get_field
472
473Returns a field by the name provided.
474
475 my $field = $table->get_field('foo');
476
477=cut
478
558482f7 479sub get_field {
43b9dc7a 480 my $self = shift;
481 my $field_name = shift or return $self->error('No field name');
3a7eb46e 482 my $case_insensitive = shift;
558482f7 483 return $self->error(qq[Field "$field_name" does not exist])
484 unless $self->_has_fields;
3a7eb46e 485 if ( $case_insensitive ) {
ea93df61 486 $field_name = uc($field_name);
558482f7 487 foreach my $field ( keys %{$self->_fields} ) {
488 return $self->_fields->{$field} if $field_name eq uc($field);
ea93df61 489 }
490 return $self->error(qq[Field "$field_name" does not exist]);
3a7eb46e 491 }
43b9dc7a 492 return $self->error( qq[Field "$field_name" does not exist] ) unless
558482f7 493 exists $self->_fields->{ $field_name };
494 return $self->_fields->{ $field_name };
43b9dc7a 495}
496
0f3cc5c0 497=head2 get_fields
498
499Returns all the field objects as an array or array reference.
500
501 my @fields = $table->get_fields;
502
503=cut
504
558482f7 505sub get_fields {
0f3cc5c0 506 my $self = shift;
ea93df61 507 my @fields =
30f4ec44 508 map { $_->[1] }
509 sort { $a->[0] <=> $b->[0] }
510 map { [ $_->order, $_ ] }
558482f7 511 values %{ $self->_has_fields ? $self->_fields : {} };
0f3cc5c0 512
513 if ( @fields ) {
514 return wantarray ? @fields : \@fields;
515 }
516 else {
517 $self->error('No fields');
c5409185 518 return;
0f3cc5c0 519 }
3c5de62a 520}
521
3c5de62a 522=head2 is_valid
523
524Determine whether the view is valid or not.
525
526 my $ok = $view->is_valid;
527
528=cut
529
558482f7 530sub is_valid {
3c5de62a 531 my $self = shift;
43b9dc7a 532 return $self->error('No name') unless $self->name;
0f3cc5c0 533 return $self->error('No fields') unless $self->get_fields;
534
ea93df61 535 for my $object (
536 $self->get_fields, $self->get_indices, $self->get_constraints
0f3cc5c0 537 ) {
538 return $object->error unless $object->is_valid;
539 }
540
541 return 1;
3c5de62a 542}
543
719915f2 544=head2 is_trivial_link
545
546True if table has no data (non-key) fields and only uses single key joins.
65157eda 547
548=cut
549
558482f7 550has is_trivial_link => ( is => 'lazy', init_arg => undef );
551
02240029 552around is_trivial_link => carp_ro('is_trivial_link');
553
558482f7 554sub _build_is_trivial_link {
65157eda 555 my $self = shift;
556 return 0 if $self->is_data;
65157eda 557
558 my %fk = ();
559
560 foreach my $field ( $self->get_fields ) {
ea93df61 561 next unless $field->is_foreign_key;
562 $fk{$field->foreign_key_reference->reference_table}++;
563 }
65157eda 564
565 foreach my $referenced (keys %fk){
ea93df61 566 if($fk{$referenced} > 1){
558482f7 567 return 0;
ea93df61 568 }
3d6c9056 569 }
65157eda 570
558482f7 571 return 1;
65157eda 572}
573
870024f3 574=head2 is_data
575
719915f2 576Returns true if the table has some non-key fields.
577
870024f3 578=cut
579
558482f7 580has is_data => ( is => 'lazy', init_arg => undef );
69c7a62f 581
02240029 582around is_data => carp_ro('is_data');
583
558482f7 584sub _build_is_data {
585 my $self = shift;
69c7a62f 586
870024f3 587 foreach my $field ( $self->get_fields ) {
588 if ( !$field->is_primary_key and !$field->is_foreign_key ) {
558482f7 589 return 1;
870024f3 590 }
591 }
592
558482f7 593 return 0;
69c7a62f 594}
595
69c7a62f 596=head2 can_link
597
598Determine whether the table can link two arg tables via many-to-many.
599
600 my $ok = $table->can_link($table1,$table2);
601
602=cut
603
68d75205 604has _can_link => ( is => 'ro', init_arg => undef, default => quote_sub(q{ +{} }) );
558482f7 605
606sub can_link {
870024f3 607 my ( $self, $table1, $table2 ) = @_;
608
558482f7 609 return $self->_can_link->{ $table1->name }{ $table2->name }
610 if defined $self->_can_link->{ $table1->name }{ $table2->name };
870024f3 611
612 if ( $self->is_data == 1 ) {
558482f7 613 $self->_can_link->{ $table1->name }{ $table2->name } = [0];
614 $self->_can_link->{ $table2->name }{ $table1->name } = [0];
615 return $self->_can_link->{ $table1->name }{ $table2->name };
870024f3 616 }
617
618 my %fk = ();
619
620 foreach my $field ( $self->get_fields ) {
621 if ( $field->is_foreign_key ) {
622 push @{ $fk{ $field->foreign_key_reference->reference_table } },
623 $field->foreign_key_reference;
624 }
625 }
626
627 if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
628 {
558482f7 629 $self->_can_link->{ $table1->name }{ $table2->name } = [0];
630 $self->_can_link->{ $table2->name }{ $table1->name } = [0];
631 return $self->_can_link->{ $table1->name }{ $table2->name };
870024f3 632 }
633
634 # trivial traversal, only one way to link the two tables
635 if ( scalar( @{ $fk{ $table1->name } } == 1 )
636 and scalar( @{ $fk{ $table2->name } } == 1 ) )
637 {
558482f7 638 $self->_can_link->{ $table1->name }{ $table2->name } =
870024f3 639 [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
558482f7 640 $self->_can_link->{ $table1->name }{ $table2->name } =
870024f3 641 [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
642
ea93df61 643 # non-trivial traversal. one way to link table2,
870024f3 644 # many ways to link table1
645 }
646 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
647 and scalar( @{ $fk{ $table2->name } } == 1 ) )
648 {
558482f7 649 $self->_can_link->{ $table1->name }{ $table2->name } =
870024f3 650 [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
558482f7 651 $self->_can_link->{ $table2->name }{ $table1->name } =
870024f3 652 [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
653
ea93df61 654 # non-trivial traversal. one way to link table1,
870024f3 655 # many ways to link table2
656 }
657 elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
658 and scalar( @{ $fk{ $table2->name } } > 1 ) )
659 {
558482f7 660 $self->_can_link->{ $table1->name }{ $table2->name } =
870024f3 661 [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
558482f7 662 $self->_can_link->{ $table2->name }{ $table1->name } =
870024f3 663 [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
664
665 # non-trivial traversal. many ways to link table1 and table2
666 }
667 elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
668 and scalar( @{ $fk{ $table2->name } } > 1 ) )
669 {
558482f7 670 $self->_can_link->{ $table1->name }{ $table2->name } =
870024f3 671 [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
558482f7 672 $self->_can_link->{ $table2->name }{ $table1->name } =
870024f3 673 [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
674
ea93df61 675 # one of the tables didn't export a key
870024f3 676 # to this table, no linking possible
677 }
678 else {
558482f7 679 $self->_can_link->{ $table1->name }{ $table2->name } = [0];
680 $self->_can_link->{ $table2->name }{ $table1->name } = [0];
870024f3 681 }
682
558482f7 683 return $self->_can_link->{ $table1->name }{ $table2->name };
69c7a62f 684}
685
dfdb0568 686=head2 name
687
870024f3 688Get or set the table's name.
dfdb0568 689
65dd38c0 690Errors ("No table name") if you try to set a blank name.
691
692If provided an argument, checks the schema object for a table of
693that name and disallows the change if one exists (setting the error to
694"Can't use table name "%s": table exists").
dfdb0568 695
696 my $table_name = $table->name('foo');
697
698=cut
699
558482f7 700has name => (
701 is => 'rw',
702 isa => sub { throw("No table name") unless $_[0] },
703);
704
705around name => sub {
706 my $orig = shift;
dfdb0568 707 my $self = shift;
708
558482f7 709 if ( my ($arg) = @_ ) {
dfdb0568 710 if ( my $schema = $self->schema ) {
870024f3 711 return $self->error( qq[Can't use table name "$arg": table exists] )
dfdb0568 712 if $schema->get_table( $arg );
713 }
dfdb0568 714 }
715
558482f7 716 return ex2err($orig, $self, @_);
717};
43b9dc7a 718
719=head2 schema
720
870024f3 721Get or set the table's schema object.
43b9dc7a 722
723 my $schema = $table->schema;
724
725=cut
726
a5bfeba8 727has schema => ( is => 'rw', isa => schema_obj('Schema'), weak_ref => 1 );
43b9dc7a 728
558482f7 729around schema => \&ex2err;
43b9dc7a 730
43b9dc7a 731sub primary_key {
732
733=pod
734
870024f3 735=head2 primary_key
43b9dc7a 736
870024f3 737Gets or sets the table's primary key(s). Takes one or more field
5e84ac85 738names (as a string, list or array[ref]) as an argument. If the field
739names are present, it will create a new PK if none exists, or it will
740add to the fields of an existing PK (and will unique the field names).
741Returns the C<SQL::Translator::Schema::Constraint> object representing
742the primary key.
743
7e95adcb 744These are equivalent:
43b9dc7a 745
746 $table->primary_key('id');
5e84ac85 747 $table->primary_key(['name']);
748 $table->primary_key('id','name']);
43b9dc7a 749 $table->primary_key(['id','name']);
750 $table->primary_key('id,name');
751 $table->primary_key(qw[ id name ]);
752
753 my $pk = $table->primary_key;
754
755=cut
756
30f4ec44 757 my $self = shift;
758 my $fields = parse_list_arg( @_ );
43b9dc7a 759
5e84ac85 760 my $constraint;
43b9dc7a 761 if ( @$fields ) {
762 for my $f ( @$fields ) {
ea93df61 763 return $self->error(qq[Invalid field "$f"]) unless
43b9dc7a 764 $self->get_field($f);
765 }
766
767 my $has_pk;
768 for my $c ( $self->get_constraints ) {
769 if ( $c->type eq PRIMARY_KEY ) {
770 $has_pk = 1;
771 $c->fields( @{ $c->fields }, @$fields );
5e84ac85 772 $constraint = $c;
ea93df61 773 }
43b9dc7a 774 }
775
776 unless ( $has_pk ) {
5e84ac85 777 $constraint = $self->add_constraint(
43b9dc7a 778 type => PRIMARY_KEY,
779 fields => $fields,
88b8377e 780 ) or return;
43b9dc7a 781 }
782 }
783
5e84ac85 784 if ( $constraint ) {
785 return $constraint;
786 }
787 else {
788 for my $c ( $self->get_constraints ) {
789 return $c if $c->type eq PRIMARY_KEY;
790 }
43b9dc7a 791 }
792
dfdb0568 793 return;
43b9dc7a 794}
795
43b9dc7a 796=head2 options
797
6d060264 798Get or append to the table's options (e.g., table types for MySQL).
799Returns an array or array reference.
43b9dc7a 800
801 my @options = $table->options;
802
803=cut
804
0fb58589 805with ListAttr options => ( append => 1 );
30f4ec44 806
807=head2 order
808
870024f3 809Get or set the table's order.
30f4ec44 810
811 my $order = $table->order(3);
812
813=cut
814
68d75205 815has order => ( is => 'rw', default => quote_sub(q{ 0 }) );
558482f7 816
817around order => sub {
818 my ( $orig, $self, $arg ) = @_;
30f4ec44 819
820 if ( defined $arg && $arg =~ /^\d+$/ ) {
558482f7 821 return $self->$orig($arg);
30f4ec44 822 }
823
558482f7 824 return $self->$orig;
825};
719915f2 826
827=head2 field_names
828
829Read-only method to return a list or array ref of the field names. Returns undef
10f70490 830or an empty list if the table has no fields set. Useful if you want to
719915f2 831avoid the overload magic of the Field objects returned by the get_fields method.
832
833 my @names = $constraint->field_names;
834
835=cut
836
558482f7 837sub field_names {
719915f2 838 my $self = shift;
ea93df61 839 my @fields =
719915f2 840 map { $_->name }
558482f7 841 $self->get_fields;
719915f2 842
843 if ( @fields ) {
844 return wantarray ? @fields : \@fields;
845 }
846 else {
847 $self->error('No fields');
c5409185 848 return;
719915f2 849 }
850}
851
abf315bb 852sub equals {
853
854=pod
855
856=head2 equals
857
858Determines if this table is the same as another
859
860 my $isIdentical = $table1->equals( $table2 );
861
862=cut
863
864 my $self = shift;
865 my $other = shift;
d6d17119 866 my $case_insensitive = shift;
ea93df61 867
abf315bb 868 return 0 unless $self->SUPER::equals($other);
d6d17119 869 return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
4598b71c 870 return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
871 return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
abf315bb 872
873 # Fields
874 # Go through our fields
875 my %checkedFields;
876 foreach my $field ( $self->get_fields ) {
ea93df61 877 my $otherField = $other->get_field($field->name, $case_insensitive);
878 return 0 unless $field->equals($otherField, $case_insensitive);
879 $checkedFields{$field->name} = 1;
abf315bb 880 }
881 # Go through the other table's fields
882 foreach my $otherField ( $other->get_fields ) {
ea93df61 883 next if $checkedFields{$otherField->name};
884 return 0;
abf315bb 885 }
886
887 # Constraints
888 # Go through our constraints
889 my %checkedConstraints;
890CONSTRAINT:
891 foreach my $constraint ( $self->get_constraints ) {
ea93df61 892 foreach my $otherConstraint ( $other->get_constraints ) {
893 if ( $constraint->equals($otherConstraint, $case_insensitive) ) {
894 $checkedConstraints{$otherConstraint} = 1;
895 next CONSTRAINT;
896 }
897 }
898 return 0;
abf315bb 899 }
900 # Go through the other table's constraints
686b14be 901CONSTRAINT2:
abf315bb 902 foreach my $otherConstraint ( $other->get_constraints ) {
ea93df61 903 next if $checkedFields{$otherConstraint};
904 foreach my $constraint ( $self->get_constraints ) {
905 if ( $otherConstraint->equals($constraint, $case_insensitive) ) {
906 next CONSTRAINT2;
907 }
908 }
909 return 0;
abf315bb 910 }
911
912 # Indices
913 # Go through our indices
914 my %checkedIndices;
915INDEX:
916 foreach my $index ( $self->get_indices ) {
ea93df61 917 foreach my $otherIndex ( $other->get_indices ) {
918 if ( $index->equals($otherIndex, $case_insensitive) ) {
919 $checkedIndices{$otherIndex} = 1;
920 next INDEX;
921 }
922 }
923 return 0;
abf315bb 924 }
686b14be 925 # Go through the other table's indices
926INDEX2:
abf315bb 927 foreach my $otherIndex ( $other->get_indices ) {
ea93df61 928 next if $checkedIndices{$otherIndex};
929 foreach my $index ( $self->get_indices ) {
930 if ( $otherIndex->equals($index, $case_insensitive) ) {
931 next INDEX2;
932 }
933 }
934 return 0;
abf315bb 935 }
936
ea93df61 937 return 1;
abf315bb 938}
939
719915f2 940=head1 LOOKUP METHODS
941
ea93df61 942The following are a set of shortcut methods for getting commonly used lists of
943fields and constraints. They all return lists or array refs of Field or
719915f2 944Constraint objects.
945
946=over 4
947
948=item pkey_fields
949
950The primary key fields.
951
952=item fkey_fields
953
954All foreign key fields.
955
956=item nonpkey_fields
957
958All the fields except the primary key.
959
960=item data_fields
961
962All non key fields.
963
964=item unique_fields
965
966All fields with unique constraints.
967
968=item unique_constraints
969
970All this tables unique constraints.
971
972=item fkey_constraints
973
974All this tables foreign key constraints. (See primary_key method to get the
975primary key constraint)
976
977=back
978
979=cut
980
981sub pkey_fields {
982 my $me = shift;
983 my @fields = grep { $_->is_primary_key } $me->get_fields;
984 return wantarray ? @fields : \@fields;
985}
986
719915f2 987sub fkey_fields {
988 my $me = shift;
989 my @fields;
990 push @fields, $_->fields foreach $me->fkey_constraints;
991 return wantarray ? @fields : \@fields;
992}
993
719915f2 994sub nonpkey_fields {
995 my $me = shift;
996 my @fields = grep { !$_->is_primary_key } $me->get_fields;
997 return wantarray ? @fields : \@fields;
998}
999
719915f2 1000sub data_fields {
1001 my $me = shift;
1002 my @fields =
1003 grep { !$_->is_foreign_key and !$_->is_primary_key } $me->get_fields;
1004 return wantarray ? @fields : \@fields;
1005}
1006
719915f2 1007sub unique_fields {
1008 my $me = shift;
1009 my @fields;
1010 push @fields, $_->fields foreach $me->unique_constraints;
1011 return wantarray ? @fields : \@fields;
1012}
1013
719915f2 1014sub unique_constraints {
1015 my $me = shift;
1016 my @cons = grep { $_->type eq UNIQUE } $me->get_constraints;
1017 return wantarray ? @cons : \@cons;
1018}
1019
719915f2 1020sub fkey_constraints {
1021 my $me = shift;
1022 my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints;
1023 return wantarray ? @cons : \@cons;
1024}
1025
558482f7 1026# Must come after all 'has' declarations
1027around new => \&ex2err;
1028
3c5de62a 10291;
1030
3c5de62a 1031=pod
1032
870024f3 1033=head1 AUTHORS
3c5de62a 1034
c3b0b535 1035Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
870024f3 1036Allen Day E<lt>allenday@ucla.eduE<gt>.
3c5de62a 1037
1038=cut