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