Made debugging work and it now exports its parse method.
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Schema / Table.pm
1 package SQL::Translator::Schema::Table;
2
3 # ----------------------------------------------------------------------
4 # $Id: Table.pm,v 1.23 2003-10-04 01:22:04 kycl4rk Exp $
5 # ----------------------------------------------------------------------
6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>
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 Class::Base;
44 use SQL::Translator::Utils 'parse_list_arg';
45 use SQL::Translator::Schema::Constants;
46 use SQL::Translator::Schema::Constraint;
47 use SQL::Translator::Schema::Field;
48 use SQL::Translator::Schema::Index;
49 use Data::Dumper;
50
51 use base 'Class::Base';
52 use vars qw( $VERSION $FIELD_ORDER );
53
54 $VERSION = sprintf "%d.%02d", q$Revision: 1.23 $ =~ /(\d+)\.(\d+)/;
55
56 # ----------------------------------------------------------------------
57 sub init {
58
59 =pod
60
61 =head2 new
62
63 Object constructor.
64
65   my $table  =  SQL::Translator::Schema::Table->new( 
66       schema => $schema,
67       name   => 'foo',
68   );
69
70 =cut
71
72     my ( $self, $config ) = @_;
73     
74     for my $arg ( qw[ schema name comments ] ) {
75         next unless defined $config->{ $arg };
76         defined $self->$arg( $config->{ $arg } ) or return;
77     }
78
79     return $self;
80 }
81
82 # ----------------------------------------------------------------------
83 sub add_constraint {
84
85 =pod
86
87 =head2 add_constraint
88
89 Add a constraint to the table.  Returns the newly created 
90 C<SQL::Translator::Schema::Constraint> object.
91
92   my $c1     = $table->add_constraint(
93       name   => 'pk',
94       type   => PRIMARY_KEY,
95       fields => [ 'foo_id' ],
96   );
97
98   my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
99   $c2    = $table->add_constraint( $constraint );
100
101 =cut
102
103     my $self             = shift;
104     my $constraint_class = 'SQL::Translator::Schema::Constraint';
105     my $constraint;
106
107     if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
108         $constraint = shift;
109         $constraint->table( $self );
110     }
111     else {
112         my %args = @_;
113         $args{'table'} = $self;
114         $constraint = $constraint_class->new( \%args ) or 
115             return $self->error( $constraint_class->error );
116     }
117
118     #
119     # If we're trying to add a PK when one is already defined,
120     # then just add the fields to the existing definition.
121     #
122     my $ok = 1;
123     my $pk = $self->primary_key;
124     if ( $pk && $constraint->type eq PRIMARY_KEY ) {
125         $self->primary_key( $constraint->fields );
126         $constraint = $pk;
127         $ok         = 0;
128     }
129     elsif ( $constraint->type eq PRIMARY_KEY ) {
130         for my $fname ( $constraint->fields ) {
131             if ( my $f = $self->get_field( $fname ) ) {
132                 $f->is_primary_key( 1 );
133             }
134         }
135     }
136     #
137     # See if another constraint of the same type 
138     # covers the same fields.  -- This doesn't work!  ky
139     #
140 #    elsif ( $constraint->type ne CHECK_C ) {
141 #        my @field_names = $constraint->fields;
142 #        for my $c ( 
143 #            grep { $_->type eq $constraint->type } 
144 #            $self->get_constraints 
145 #        ) {
146 #            my %fields = map { $_, 1 } $c->fields;
147 #            for my $field_name ( @field_names ) {
148 #                if ( $fields{ $field_name } ) {
149 #                    $constraint = $c;
150 #                    $ok = 0; 
151 #                    last;
152 #                }
153 #            }
154 #            last unless $ok;
155 #        }
156 #    }
157
158     if ( $ok ) {
159         push @{ $self->{'constraints'} }, $constraint;
160     }
161
162     return $constraint;
163 }
164
165 # ----------------------------------------------------------------------
166 sub add_index {
167
168 =pod
169
170 =head2 add_index
171
172 Add an index to the table.  Returns the newly created
173 C<SQL::Translator::Schema::Index> object.
174
175   my $i1     = $table->add_index(
176       name   => 'name',
177       fields => [ 'name' ],
178       type   => 'normal',
179   );
180
181   my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
182   $i2    = $table->add_index( $index );
183
184 =cut
185
186     my $self        = shift;
187     my $index_class = 'SQL::Translator::Schema::Index';
188     my $index;
189
190     if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
191         $index = shift;
192         $index->table( $self );
193     }
194     else {
195         my %args = @_;
196         $args{'table'} = $self;
197         $index = $index_class->new( \%args ) or return 
198             $self->error( $index_class->error );
199     }
200
201     push @{ $self->{'indices'} }, $index;
202     return $index;
203 }
204
205 # ----------------------------------------------------------------------
206 sub add_field {
207
208 =pod
209
210 =head2 add_field
211
212 Add an field to the table.  Returns the newly created
213 C<SQL::Translator::Schema::Field> object.  The "name" parameter is 
214 required.  If you try to create a field with the same name as an 
215 existing field, you will get an error and the field will not be created.
216
217   my $f1        =  $table->add_field(
218       name      => 'foo_id',
219       data_type => 'integer',
220       size      => 11,
221   );
222
223   my $f2     =  SQL::Translator::Schema::Field->new( 
224       name   => 'name', 
225       table  => $table,
226   );
227   $f2 = $table->add_field( $field2 ) or die $table->error;
228
229 =cut
230
231     my $self        = shift;
232     my $field_class = 'SQL::Translator::Schema::Field';
233     my $field;
234
235     if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
236         $field = shift;
237         $field->table( $self );
238     }
239     else {
240         my %args = @_;
241         $args{'table'} = $self;
242         $field = $field_class->new( \%args ) or return 
243             $self->error( $field_class->error );
244     }
245
246     $field->order( ++$FIELD_ORDER );
247     my $field_name = $field->name or return $self->error('No name');
248
249     if ( exists $self->{'fields'}{ $field_name } ) { 
250         return $self->error(qq[Can't create field: "$field_name" exists]);
251     }
252     else {
253         $self->{'fields'}{ $field_name } = $field;
254     }
255
256     return $field;
257 }
258
259 # ----------------------------------------------------------------------
260 sub comments {
261
262 =pod
263
264 =head2 comments
265
266 Get or set the comments on a table.  May be called several times to 
267 set and it will accumulate the comments.  Called in an array context,
268 returns each comment individually; called in a scalar context, returns
269 all the comments joined on newlines.
270
271   $table->comments('foo');
272   $table->comments('bar');
273   print join( ', ', $table->comments ); # prints "foo, bar"
274
275 =cut
276
277     my $self     = shift;
278     my @comments = ref $_[0] ? @{ $_[0] } : @_;
279
280     for my $arg ( @comments ) {
281         $arg = $arg->[0] if ref $arg;
282         push @{ $self->{'comments'} }, $arg if defined $arg && $arg;
283     }
284
285     if ( @{ $self->{'comments'} || [] } ) {
286         return wantarray 
287             ? @{ $self->{'comments'} }
288             : join( "\n", @{ $self->{'comments'} } )
289         ;
290     } 
291     else {
292         return wantarray ? () : undef;
293     }
294 }
295
296 # ----------------------------------------------------------------------
297 sub get_constraints {
298
299 =pod
300
301 =head2 get_constraints
302
303 Returns all the constraint objects as an array or array reference.
304
305   my @constraints = $table->get_constraints;
306
307 =cut
308
309     my $self = shift;
310
311     if ( ref $self->{'constraints'} ) {
312         return wantarray 
313             ? @{ $self->{'constraints'} } : $self->{'constraints'};
314     }
315     else {
316         $self->error('No constraints');
317         return wantarray ? () : undef;
318     }
319 }
320
321 # ----------------------------------------------------------------------
322 sub get_indices {
323
324 =pod
325
326 =head2 get_indices
327
328 Returns all the index objects as an array or array reference.
329
330   my @indices = $table->get_indices;
331
332 =cut
333
334     my $self = shift;
335
336     if ( ref $self->{'indices'} ) {
337         return wantarray 
338             ? @{ $self->{'indices'} } 
339             : $self->{'indices'};
340     }
341     else {
342         $self->error('No indices');
343         return wantarray ? () : undef;
344     }
345 }
346
347 # ----------------------------------------------------------------------
348 sub get_field {
349
350 =pod
351
352 =head2 get_field
353
354 Returns a field by the name provided.
355
356   my $field = $table->get_field('foo');
357
358 =cut
359
360     my $self       = shift;
361     my $field_name = shift or return $self->error('No field name');
362     return $self->error( qq[Field "$field_name" does not exist] ) unless
363         exists $self->{'fields'}{ $field_name };
364     return $self->{'fields'}{ $field_name };
365 }
366
367 # ----------------------------------------------------------------------
368 sub get_fields {
369
370 =pod
371
372 =head2 get_fields
373
374 Returns all the field objects as an array or array reference.
375
376   my @fields = $table->get_fields;
377
378 =cut
379
380     my $self = shift;
381     my @fields = 
382         map  { $_->[1] }
383         sort { $a->[0] <=> $b->[0] }
384         map  { [ $_->order, $_ ] }
385         values %{ $self->{'fields'} || {} };
386
387     if ( @fields ) {
388         return wantarray ? @fields : \@fields;
389     }
390     else {
391         $self->error('No fields');
392         return wantarray ? () : undef;
393     }
394 }
395
396 # ----------------------------------------------------------------------
397 sub is_valid {
398
399 =pod
400
401 =head2 is_valid
402
403 Determine whether the view is valid or not.
404
405   my $ok = $view->is_valid;
406
407 =cut
408
409     my $self = shift;
410     return $self->error('No name')   unless $self->name;
411     return $self->error('No fields') unless $self->get_fields;
412
413     for my $object ( 
414         $self->get_fields, $self->get_indices, $self->get_constraints 
415     ) {
416         return $object->error unless $object->is_valid;
417     }
418
419     return 1;
420 }
421
422 # ----------------------------------------------------------------------
423 sub is_trivial_link {
424
425 =pod
426
427 =head2 is_data
428
429 =cut
430
431     my $self = shift;
432     return 0 if $self->is_data;
433     return $self->{'is_trivial_link'} if defined $self->{'is_trivial_link'};
434
435     $self->{'is_trivial_link'} = 1;
436
437     my %fk = ();
438
439     foreach my $field ( $self->get_fields ) {
440           next unless $field->is_foreign_key;
441           $fk{$field->foreign_key_reference->reference_table}++;
442         }
443
444     foreach my $referenced (keys %fk){
445         if($fk{$referenced} > 1){
446           $self->{'is_trivial_link'} = 0;
447           last;
448         }
449     }
450
451     return $self->{'is_trivial_link'};
452
453 }
454
455 sub is_data {
456
457 =pod
458
459 =head2 is_data
460
461 =cut
462
463     my $self = shift;
464     return $self->{'is_data'} if defined $self->{'is_data'};
465
466     $self->{'is_data'} = 0;
467
468     foreach my $field ( $self->get_fields ) {
469         if ( !$field->is_primary_key and !$field->is_foreign_key ) {
470             $self->{'is_data'} = 1;
471             return $self->{'is_data'};
472         }
473     }
474
475     return $self->{'is_data'};
476 }
477
478 # ----------------------------------------------------------------------
479 sub can_link {
480
481 =pod
482
483 =head2 can_link
484
485 Determine whether the table can link two arg tables via many-to-many.
486
487   my $ok = $table->can_link($table1,$table2);
488
489 =cut
490
491     my ( $self, $table1, $table2 ) = @_;
492
493     return $self->{'can_link'}{ $table1->name }{ $table2->name }
494       if defined $self->{'can_link'}{ $table1->name }{ $table2->name };
495
496     if ( $self->is_data == 1 ) {
497         $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
498         $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
499         return $self->{'can_link'}{ $table1->name }{ $table2->name };
500     }
501
502     my %fk = ();
503
504     foreach my $field ( $self->get_fields ) {
505         if ( $field->is_foreign_key ) {
506             push @{ $fk{ $field->foreign_key_reference->reference_table } },
507               $field->foreign_key_reference;
508         }
509     }
510
511     if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) )
512     {
513         $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
514         $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
515         return $self->{'can_link'}{ $table1->name }{ $table2->name };
516     }
517
518     # trivial traversal, only one way to link the two tables
519     if (    scalar( @{ $fk{ $table1->name } } == 1 )
520         and scalar( @{ $fk{ $table2->name } } == 1 ) )
521     {
522         $self->{'can_link'}{ $table1->name }{ $table2->name } =
523           [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ];
524         $self->{'can_link'}{ $table1->name }{ $table2->name } =
525           [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
526
527         # non-trivial traversal.  one way to link table2, 
528         # many ways to link table1
529     }
530     elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
531         and scalar( @{ $fk{ $table2->name } } == 1 ) )
532     {
533         $self->{'can_link'}{ $table1->name }{ $table2->name } =
534           [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ];
535         $self->{'can_link'}{ $table2->name }{ $table1->name } =
536           [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
537
538         # non-trivial traversal.  one way to link table1, 
539         # many ways to link table2
540     }
541     elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
542         and scalar( @{ $fk{ $table2->name } } > 1 ) )
543     {
544         $self->{'can_link'}{ $table1->name }{ $table2->name } =
545           [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ];
546         $self->{'can_link'}{ $table2->name }{ $table1->name } =
547           [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ];
548
549         # non-trivial traversal.  many ways to link table1 and table2
550     }
551     elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
552         and scalar( @{ $fk{ $table2->name } } > 1 ) )
553     {
554         $self->{'can_link'}{ $table1->name }{ $table2->name } =
555           [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ];
556         $self->{'can_link'}{ $table2->name }{ $table1->name } =
557           [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
558
559         # one of the tables didn't export a key 
560         # to this table, no linking possible
561     }
562     else {
563         $self->{'can_link'}{ $table1->name }{ $table2->name } = [0];
564         $self->{'can_link'}{ $table2->name }{ $table1->name } = [0];
565     }
566
567     return $self->{'can_link'}{ $table1->name }{ $table2->name };
568 }
569
570 # ----------------------------------------------------------------------
571 sub name {
572
573 =pod
574
575 =head2 name
576
577 Get or set the table's name.
578
579 If provided an argument, checks the schema object for a table of 
580 that name and disallows the change if one exists.
581
582   my $table_name = $table->name('foo');
583
584 =cut
585
586     my $self = shift;
587
588     if ( my $arg = shift ) {
589         if ( my $schema = $self->schema ) {
590             return $self->error( qq[Can't use table name "$arg": table exists] )
591                 if $schema->get_table( $arg );
592         }
593         $self->{'name'} = $arg;
594     }
595
596     return $self->{'name'} || '';
597 }
598
599 # ----------------------------------------------------------------------
600 sub schema {
601
602 =pod
603
604 =head2 schema
605
606 Get or set the table's schema object.
607
608   my $schema = $table->schema;
609
610 =cut
611
612     my $self = shift;
613     if ( my $arg = shift ) {
614         return $self->error('Not a schema object') unless
615             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
616         $self->{'schema'} = $arg;
617     }
618
619     return $self->{'schema'};
620 }
621
622 # ----------------------------------------------------------------------
623 sub primary_key {
624
625 =pod
626
627 =head2 primary_key
628
629 Gets or sets the table's primary key(s).  Takes one or more field
630 names (as a string, list or array[ref]) as an argument.  If the field
631 names are present, it will create a new PK if none exists, or it will
632 add to the fields of an existing PK (and will unique the field names).
633 Returns the C<SQL::Translator::Schema::Constraint> object representing
634 the primary key.
635
636 These are eqivalent:
637
638   $table->primary_key('id');
639   $table->primary_key(['name']);
640   $table->primary_key('id','name']);
641   $table->primary_key(['id','name']);
642   $table->primary_key('id,name');
643   $table->primary_key(qw[ id name ]);
644
645   my $pk = $table->primary_key;
646
647 =cut
648
649     my $self   = shift;
650     my $fields = parse_list_arg( @_ );
651
652     my $constraint;
653     if ( @$fields ) {
654         for my $f ( @$fields ) {
655             return $self->error(qq[Invalid field "$f"]) unless 
656                 $self->get_field($f);
657         }
658
659         my $has_pk;
660         for my $c ( $self->get_constraints ) {
661             if ( $c->type eq PRIMARY_KEY ) {
662                 $has_pk = 1;
663                 $c->fields( @{ $c->fields }, @$fields );
664                 $constraint = $c;
665             } 
666         }
667
668         unless ( $has_pk ) {
669             $constraint = $self->add_constraint(
670                 type   => PRIMARY_KEY,
671                 fields => $fields,
672             ) or return;
673         }
674     }
675
676     if ( $constraint ) {
677         return $constraint;
678     }
679     else {
680         for my $c ( $self->get_constraints ) {
681             return $c if $c->type eq PRIMARY_KEY;
682         }
683     }
684
685     return;
686 }
687
688 # ----------------------------------------------------------------------
689 sub options {
690
691 =pod
692
693 =head2 options
694
695 Get or set the table's options (e.g., table types for MySQL).  Returns
696 an array or array reference.
697
698   my @options = $table->options;
699
700 =cut
701
702     my $self    = shift;
703     my $options = parse_list_arg( @_ );
704
705     push @{ $self->{'options'} }, @$options;
706
707     if ( ref $self->{'options'} ) {
708         return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
709     }
710     else {
711         return wantarray ? () : [];
712     }
713 }
714
715 # ----------------------------------------------------------------------
716 sub order {
717
718 =pod
719
720 =head2 order
721
722 Get or set the table's order.
723
724   my $order = $table->order(3);
725
726 =cut
727
728     my ( $self, $arg ) = @_;
729
730     if ( defined $arg && $arg =~ /^\d+$/ ) {
731         $self->{'order'} = $arg;
732     }
733
734     return $self->{'order'} || 0;
735 }
736
737 # ----------------------------------------------------------------------
738 sub DESTROY {
739     my $self = shift;
740     undef $self->{'schema'}; # destroy cyclical reference
741     undef $_ for @{ $self->{'constraints'} };
742     undef $_ for @{ $self->{'indices'} };
743     undef $_ for values %{ $self->{'fields'} };
744 }
745
746 1;
747
748 # ----------------------------------------------------------------------
749
750 =pod
751
752 =head1 AUTHORS
753
754 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
755 Allen Day E<lt>allenday@ucla.eduE<gt>.
756
757 =cut