Clean up option parsing and identifier quoting in Producer::PostgreSQL
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Schema / Table.pm
1 package SQL::Translator::Schema::Table;
2
3 =pod
4
5 =head1 NAME
6
7 SQL::Translator::Schema::Table - SQL::Translator table object
8
9 =head1 SYNOPSIS
10
11   use SQL::Translator::Schema::Table;
12   my $table = SQL::Translator::Schema::Table->new( name => 'foo' );
13
14 =head1 DESCRIPTION
15
16 C<SQL::Translator::Schema::Table> is the table object.
17
18 =head1 METHODS
19
20 =cut
21
22 use Moo;
23 use SQL::Translator::Utils qw(parse_list_arg ex2err throw carp_ro);
24 use SQL::Translator::Types qw(schema_obj);
25 use SQL::Translator::Role::ListAttr;
26 use SQL::Translator::Schema::Constants;
27 use SQL::Translator::Schema::Constraint;
28 use SQL::Translator::Schema::Field;
29 use SQL::Translator::Schema::Index;
30
31 use Carp::Clan '^SQL::Translator';
32 use List::Util 'max';
33 use Sub::Quote qw(quote_sub);
34
35 extends 'SQL::Translator::Schema::Object';
36
37 our $VERSION = '1.59';
38
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!).
42 use overload
43     '""'     => sub { shift->name },
44     'bool'   => sub { $_[0]->name || $_[0] },
45     fallback => 1,
46 ;
47
48 =pod
49
50 =head2 new
51
52 Object constructor.
53
54   my $table  =  SQL::Translator::Schema::Table->new(
55       schema => $schema,
56       name   => 'foo',
57   );
58
59 =head2 add_constraint
60
61 Add a constraint to the table.  Returns the newly created
62 C<SQL::Translator::Schema::Constraint> object.
63
64   my $c1     = $table->add_constraint(
65       name   => 'pk',
66       type   => PRIMARY_KEY,
67       fields => [ 'foo_id' ],
68   );
69
70   my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
71   $c2    = $table->add_constraint( $constraint );
72
73 =cut
74
75 has _constraints => (
76     is => 'ro',
77     init_arg => undef,
78     default => quote_sub(q{ +[] }),
79     predicate => 1,
80     lazy => 1,
81 );
82
83 sub add_constraint {
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;
95         $constraint = $constraint_class->new( \%args ) or
96            return $self->error( $constraint_class->error );
97     }
98
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     #
103     my $ok = 1;
104     my $pk = $self->primary_key;
105     if ( $pk && $constraint->type eq PRIMARY_KEY ) {
106         $self->primary_key( $constraint->fields );
107         $pk->name($constraint->name) if $constraint->name;
108         my %extra = $constraint->extra;
109         $pk->extra(%extra) if keys %extra;
110         $constraint = $pk;
111         $ok         = 0;
112     }
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     }
120     #
121     # See if another constraint of the same type
122     # covers the same fields.  -- This doesn't work!  ky
123     #
124 #    elsif ( $constraint->type ne CHECK_C ) {
125 #        my @field_names = $constraint->fields;
126 #        for my $c (
127 #            grep { $_->type eq $constraint->type }
128 #            $self->get_constraints
129 #        ) {
130 #            my %fields = map { $_, 1 } $c->fields;
131 #            for my $field_name ( @field_names ) {
132 #                if ( $fields{ $field_name } ) {
133 #                    $constraint = $c;
134 #                    $ok = 0;
135 #                    last;
136 #                }
137 #            }
138 #            last unless $ok;
139 #        }
140 #    }
141
142     if ( $ok ) {
143         push @{ $self->_constraints }, $constraint;
144     }
145
146     return $constraint;
147 }
148
149 =head2 drop_constraint
150
151 Remove a constraint from the table. Returns the constraint object if the index
152 was found and removed, an error otherwise. The single parameter can be either
153 an index name or an C<SQL::Translator::Schema::Constraint> object.
154
155   $table->drop_constraint('myconstraint');
156
157 =cut
158
159 sub drop_constraint {
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
171     if ( ! ($self->_has_constraints && grep { $_->name eq $constraint_name } @ { $self->_constraints }) ) {
172         return $self->error(qq[Can't drop constraint: "$constraint_name" doesn't exist]);
173     }
174
175     my @cs = @{ $self->_constraints };
176     my ($constraint_id) = grep { $cs[$_]->name eq  $constraint_name } (0..$#cs);
177     my $constraint = splice(@{$self->_constraints}, $constraint_id, 1);
178
179     return $constraint;
180 }
181
182 =head2 add_index
183
184 Add an index to the table.  Returns the newly created
185 C<SQL::Translator::Schema::Index> object.
186
187   my $i1     = $table->add_index(
188       name   => 'name',
189       fields => [ 'name' ],
190       type   => 'normal',
191   );
192
193   my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
194   $i2    = $table->add_index( $index );
195
196 =cut
197
198 has _indices => (
199     is => 'ro',
200     init_arg => undef,
201     default => quote_sub(q{ [] }),
202     predicate => 1,
203     lazy => 1,
204 );
205
206 sub add_index {
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;
218         $index = $index_class->new( \%args ) or return
219             $self->error( $index_class->error );
220     }
221     foreach my $ex_index ($self->get_indices) {
222        return if ($ex_index->equals($index));
223     }
224     push @{ $self->_indices }, $index;
225     return $index;
226 }
227
228 =head2 drop_index
229
230 Remove an index from the table. Returns the index object if the index was
231 found and removed, an error otherwise. The single parameter can be either
232 an index name of an C<SQL::Translator::Schema::Index> object.
233
234   $table->drop_index('myindex');
235
236 =cut
237
238 sub drop_index {
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
250     if ( ! ($self->_has_indices && grep { $_->name eq  $index_name } @{ $self->_indices }) ) {
251         return $self->error(qq[Can't drop index: "$index_name" doesn't exist]);
252     }
253
254     my @is = @{ $self->_indices };
255     my ($index_id) = grep { $is[$_]->name eq  $index_name } (0..$#is);
256     my $index = splice(@{$self->_indices}, $index_id, 1);
257
258     return $index;
259 }
260
261 =head2 add_field
262
263 Add an field to the table.  Returns the newly created
264 C<SQL::Translator::Schema::Field> object.  The "name" parameter is
265 required.  If you try to create a field with the same name as an
266 existing field, you will get an error and the field will not be created.
267
268   my $f1        =  $table->add_field(
269       name      => 'foo_id',
270       data_type => 'integer',
271       size      => 11,
272   );
273
274   my $f2     =  SQL::Translator::Schema::Field->new(
275       name   => 'name',
276       table  => $table,
277   );
278   $f2 = $table->add_field( $field2 ) or die $table->error;
279
280 =cut
281
282 has _fields => (
283     is => 'ro',
284     init_arg => undef,
285     default => quote_sub(q{ +{} }),
286     predicate => 1,
287     lazy => 1
288 );
289
290 sub add_field {
291     my $self        = shift;
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;
302         $field = $field_class->new( \%args ) or return
303             $self->error( $field_class->error );
304     }
305
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
331     # We know we have a name as the Field->new above errors if none given.
332     my $field_name = $field->name;
333
334     if ( $self->get_field($field_name) ) {
335         return $self->error(qq[Can't use field name "$field_name": field exists]);
336     }
337     else {
338         $self->_fields->{ $field_name } = $field;
339     }
340
341     return $field;
342 }
343
344 =head2 drop_field
345
346 Remove a field from the table. Returns the field object if the field was
347 found and removed, an error otherwise. The single parameter can be either
348 a field name or an C<SQL::Translator::Schema::Field> object.
349
350   $table->drop_field('myfield');
351
352 =cut
353
354 sub drop_field {
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
368     if ( ! ($self->_has_fields && exists $self->_fields->{ $field_name } ) ) {
369         return $self->error(qq[Can't drop field: "$field_name" doesn't exists]);
370     }
371
372     my $field = delete $self->_fields->{ $field_name };
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 }
392
393 =head2 comments
394
395 Get or set the comments on a table.  May be called several times to
396 set and it will accumulate the comments.  Called in an array context,
397 returns each comment individually; called in a scalar context, returns
398 all 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
406 has comments => (
407     is => 'rw',
408     coerce => quote_sub(q{ ref($_[0]) eq 'ARRAY' ? $_[0] : [$_[0]] }),
409     default => quote_sub(q{ [] }),
410 );
411
412 around comments => sub {
413     my $orig     = shift;
414     my $self     = shift;
415     my @comments = ref $_[0] ? @{ $_[0] } : @_;
416
417     for my $arg ( @comments ) {
418         $arg = $arg->[0] if ref $arg;
419         push @{ $self->$orig }, $arg if defined $arg && $arg;
420     }
421
422     @comments = @{$self->$orig};
423     return wantarray ? @comments
424         : @comments ? join( "\n", @comments )
425         : undef;
426 };
427
428 =head2 get_constraints
429
430 Returns all the constraint objects as an array or array reference.
431
432   my @constraints = $table->get_constraints;
433
434 =cut
435
436 sub get_constraints {
437     my $self = shift;
438
439     if ( $self->_has_constraints ) {
440         return wantarray
441             ? @{ $self->_constraints } : $self->_constraints;
442     }
443     else {
444         $self->error('No constraints');
445         return;
446     }
447 }
448
449 =head2 get_indices
450
451 Returns all the index objects as an array or array reference.
452
453   my @indices = $table->get_indices;
454
455 =cut
456
457 sub get_indices {
458     my $self = shift;
459
460     if ( $self->_has_indices ) {
461         return wantarray
462             ? @{ $self->_indices }
463             : $self->_indices;
464     }
465     else {
466         $self->error('No indices');
467         return;
468     }
469 }
470
471 =head2 get_field
472
473 Returns a field by the name provided.
474
475   my $field = $table->get_field('foo');
476
477 =cut
478
479 sub get_field {
480     my $self       = shift;
481     my $field_name = shift or return $self->error('No field name');
482     my $case_insensitive = shift;
483     return $self->error(qq[Field "$field_name" does not exist])
484         unless $self->_has_fields;
485     if ( $case_insensitive ) {
486       $field_name = uc($field_name);
487       foreach my $field ( keys %{$self->_fields} ) {
488          return $self->_fields->{$field} if $field_name eq uc($field);
489       }
490       return $self->error(qq[Field "$field_name" does not exist]);
491     }
492     return $self->error( qq[Field "$field_name" does not exist] ) unless
493         exists $self->_fields->{ $field_name };
494     return $self->_fields->{ $field_name };
495 }
496
497 =head2 get_fields
498
499 Returns all the field objects as an array or array reference.
500
501   my @fields = $table->get_fields;
502
503 =cut
504
505 sub get_fields {
506     my $self = shift;
507     my @fields =
508         map  { $_->[1] }
509         sort { $a->[0] <=> $b->[0] }
510         map  { [ $_->order, $_ ] }
511         values %{ $self->_has_fields ? $self->_fields : {} };
512
513     if ( @fields ) {
514         return wantarray ? @fields : \@fields;
515     }
516     else {
517         $self->error('No fields');
518         return;
519     }
520 }
521
522 =head2 is_valid
523
524 Determine whether the view is valid or not.
525
526   my $ok = $view->is_valid;
527
528 =cut
529
530 sub is_valid {
531     my $self = shift;
532     return $self->error('No name')   unless $self->name;
533     return $self->error('No fields') unless $self->get_fields;
534
535     for my $object (
536         $self->get_fields, $self->get_indices, $self->get_constraints
537     ) {
538         return $object->error unless $object->is_valid;
539     }
540
541     return 1;
542 }
543
544 =head2 is_trivial_link
545
546 True if table has no data (non-key) fields and only uses single key joins.
547
548 =cut
549
550 has is_trivial_link => ( is => 'lazy', init_arg => undef );
551
552 around is_trivial_link => carp_ro('is_trivial_link');
553
554 sub _build_is_trivial_link {
555     my $self = shift;
556     return 0 if $self->is_data;
557
558     my %fk = ();
559
560     foreach my $field ( $self->get_fields ) {
561      next unless $field->is_foreign_key;
562      $fk{$field->foreign_key_reference->reference_table}++;
563    }
564
565     foreach my $referenced (keys %fk){
566    if($fk{$referenced} > 1){
567        return 0;
568    }
569     }
570
571     return 1;
572 }
573
574 =head2 is_data
575
576 Returns true if the table has some non-key fields.
577
578 =cut
579
580 has is_data => ( is => 'lazy', init_arg => undef );
581
582 around is_data => carp_ro('is_data');
583
584 sub _build_is_data {
585     my $self = shift;
586
587     foreach my $field ( $self->get_fields ) {
588         if ( !$field->is_primary_key and !$field->is_foreign_key ) {
589             return 1;
590         }
591     }
592
593     return 0;
594 }
595
596 =head2 can_link
597
598 Determine 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
604 has _can_link => ( is => 'ro', init_arg => undef, default => quote_sub(q{ +{} }) );
605
606 sub can_link {
607     my ( $self, $table1, $table2 ) = @_;
608
609     return $self->_can_link->{ $table1->name }{ $table2->name }
610       if defined $self->_can_link->{ $table1->name }{ $table2->name };
611
612     if ( $self->is_data == 1 ) {
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 };
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     {
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 };
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     {
638         $self->_can_link->{ $table1->name }{ $table2->name } =
639           [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
640         $self->_can_link->{ $table1->name }{ $table2->name } =
641           [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
642
643         # non-trivial traversal.  one way to link table2,
644         # many ways to link table1
645     }
646     elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
647         and scalar( @{ $fk{ $table2->name } } == 1 ) )
648     {
649         $self->_can_link->{ $table1->name }{ $table2->name } =
650           [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
651         $self->_can_link->{ $table2->name }{ $table1->name } =
652           [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
653
654         # non-trivial traversal.  one way to link table1,
655         # many ways to link table2
656     }
657     elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
658         and scalar( @{ $fk{ $table2->name } } > 1 ) )
659     {
660         $self->_can_link->{ $table1->name }{ $table2->name } =
661           [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
662         $self->_can_link->{ $table2->name }{ $table1->name } =
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     {
670         $self->_can_link->{ $table1->name }{ $table2->name } =
671           [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
672         $self->_can_link->{ $table2->name }{ $table1->name } =
673           [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
674
675         # one of the tables didn't export a key
676         # to this table, no linking possible
677     }
678     else {
679         $self->_can_link->{ $table1->name }{ $table2->name } = [0];
680         $self->_can_link->{ $table2->name }{ $table1->name } = [0];
681     }
682
683     return $self->_can_link->{ $table1->name }{ $table2->name };
684 }
685
686 =head2 name
687
688 Get or set the table's name.
689
690 Errors ("No table name") if you try to set a blank name.
691
692 If provided an argument, checks the schema object for a table of
693 that name and disallows the change if one exists (setting the error to
694 "Can't use table name "%s": table exists").
695
696   my $table_name = $table->name('foo');
697
698 =cut
699
700 has name => (
701     is => 'rw',
702     isa => sub { throw("No table name") unless $_[0] },
703 );
704
705 around name => sub {
706     my $orig = shift;
707     my $self = shift;
708
709     if ( my ($arg) = @_ ) {
710         if ( my $schema = $self->schema ) {
711             return $self->error( qq[Can't use table name "$arg": table exists] )
712                 if $schema->get_table( $arg );
713         }
714     }
715
716     return ex2err($orig, $self, @_);
717 };
718
719 =head2 schema
720
721 Get or set the table's schema object.
722
723   my $schema = $table->schema;
724
725 =cut
726
727 has schema => ( is => 'rw', isa => schema_obj('Schema'), weak_ref => 1 );
728
729 around schema => \&ex2err;
730
731 sub primary_key {
732
733 =pod
734
735 =head2 primary_key
736
737 Gets or sets the table's primary key(s).  Takes one or more field
738 names (as a string, list or array[ref]) as an argument.  If the field
739 names are present, it will create a new PK if none exists, or it will
740 add to the fields of an existing PK (and will unique the field names).
741 Returns the C<SQL::Translator::Schema::Constraint> object representing
742 the primary key.
743
744 These are equivalent:
745
746   $table->primary_key('id');
747   $table->primary_key(['name']);
748   $table->primary_key('id','name']);
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
757     my $self   = shift;
758     my $fields = parse_list_arg( @_ );
759
760     my $constraint;
761     if ( @$fields ) {
762         for my $f ( @$fields ) {
763             return $self->error(qq[Invalid field "$f"]) unless
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 );
772                 $constraint = $c;
773             }
774         }
775
776         unless ( $has_pk ) {
777             $constraint = $self->add_constraint(
778                 type   => PRIMARY_KEY,
779                 fields => $fields,
780             ) or return;
781         }
782     }
783
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         }
791     }
792
793     return;
794 }
795
796 =head2 options
797
798 Get or append to the table's options (e.g., table types for MySQL).
799 Returns an array or array reference.
800
801   my @options = $table->options;
802
803 =cut
804
805 with ListAttr options => ( append => 1 );
806
807 =head2 order
808
809 Get or set the table's order.
810
811   my $order = $table->order(3);
812
813 =cut
814
815 has order => ( is => 'rw', default => quote_sub(q{ 0 }) );
816
817 around order => sub {
818     my ( $orig, $self, $arg ) = @_;
819
820     if ( defined $arg && $arg =~ /^\d+$/ ) {
821         return $self->$orig($arg);
822     }
823
824     return $self->$orig;
825 };
826
827 =head2 field_names
828
829 Read-only method to return a list or array ref of the field names. Returns undef
830 or an empty list if the table has no fields set. Useful if you want to
831 avoid the overload magic of the Field objects returned by the get_fields method.
832
833   my @names = $constraint->field_names;
834
835 =cut
836
837 sub field_names {
838     my $self = shift;
839     my @fields =
840         map  { $_->name }
841         $self->get_fields;
842
843     if ( @fields ) {
844         return wantarray ? @fields : \@fields;
845     }
846     else {
847         $self->error('No fields');
848         return;
849     }
850 }
851
852 sub equals {
853
854 =pod
855
856 =head2 equals
857
858 Determines 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;
866     my $case_insensitive = shift;
867
868     return 0 unless $self->SUPER::equals($other);
869     return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
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);
872
873     # Fields
874     # Go through our fields
875     my %checkedFields;
876     foreach my $field ( $self->get_fields ) {
877       my $otherField = $other->get_field($field->name, $case_insensitive);
878       return 0 unless $field->equals($otherField, $case_insensitive);
879       $checkedFields{$field->name} = 1;
880     }
881     # Go through the other table's fields
882     foreach my $otherField ( $other->get_fields ) {
883       next if $checkedFields{$otherField->name};
884       return 0;
885     }
886
887     # Constraints
888     # Go through our constraints
889     my %checkedConstraints;
890 CONSTRAINT:
891     foreach my $constraint ( $self->get_constraints ) {
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;
899     }
900     # Go through the other table's constraints
901 CONSTRAINT2:
902     foreach my $otherConstraint ( $other->get_constraints ) {
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;
910     }
911
912     # Indices
913     # Go through our indices
914     my %checkedIndices;
915 INDEX:
916     foreach my $index ( $self->get_indices ) {
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;
924     }
925     # Go through the other table's indices
926 INDEX2:
927     foreach my $otherIndex ( $other->get_indices ) {
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;
935     }
936
937    return 1;
938 }
939
940 =head1 LOOKUP METHODS
941
942 The following are a set of shortcut methods for getting commonly used lists of
943 fields and constraints. They all return lists or array refs of Field or
944 Constraint objects.
945
946 =over 4
947
948 =item pkey_fields
949
950 The primary key fields.
951
952 =item fkey_fields
953
954 All foreign key fields.
955
956 =item nonpkey_fields
957
958 All the fields except the primary key.
959
960 =item data_fields
961
962 All non key fields.
963
964 =item unique_fields
965
966 All fields with unique constraints.
967
968 =item unique_constraints
969
970 All this tables unique constraints.
971
972 =item fkey_constraints
973
974 All this tables foreign key constraints. (See primary_key method to get the
975 primary key constraint)
976
977 =back
978
979 =cut
980
981 sub pkey_fields {
982     my $me = shift;
983     my @fields = grep { $_->is_primary_key } $me->get_fields;
984     return wantarray ? @fields : \@fields;
985 }
986
987 sub fkey_fields {
988     my $me = shift;
989     my @fields;
990     push @fields, $_->fields foreach $me->fkey_constraints;
991     return wantarray ? @fields : \@fields;
992 }
993
994 sub nonpkey_fields {
995     my $me = shift;
996     my @fields = grep { !$_->is_primary_key } $me->get_fields;
997     return wantarray ? @fields : \@fields;
998 }
999
1000 sub 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
1007 sub unique_fields {
1008     my $me = shift;
1009     my @fields;
1010     push @fields, $_->fields foreach $me->unique_constraints;
1011     return wantarray ? @fields : \@fields;
1012 }
1013
1014 sub unique_constraints {
1015     my $me = shift;
1016     my @cons = grep { $_->type eq UNIQUE } $me->get_constraints;
1017     return wantarray ? @cons : \@cons;
1018 }
1019
1020 sub fkey_constraints {
1021     my $me = shift;
1022     my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints;
1023     return wantarray ? @cons : \@cons;
1024 }
1025
1026 # Must come after all 'has' declarations
1027 around new => \&ex2err;
1028
1029 1;
1030
1031 =pod
1032
1033 =head1 AUTHORS
1034
1035 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
1036 Allen Day E<lt>allenday@ucla.eduE<gt>.
1037
1038 =cut