Added link to CPAN ratings.
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Schema / Table.pm
1 package SQL::Translator::Schema::Table;
2
3 # ----------------------------------------------------------------------
4 # $Id: Table.pm,v 1.13 2003-08-21 18:10:47 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
50 use base 'Class::Base';
51 use vars qw( $VERSION $FIELD_ORDER );
52
53 $VERSION = sprintf "%d.%02d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/;
54
55 # ----------------------------------------------------------------------
56 sub init {
57
58 =pod
59
60 =head2 new
61
62 Object constructor.
63
64   my $table  =  SQL::Translator::Schema::Table->new( 
65       schema => $schema,
66       name   => 'foo',
67   );
68
69 =cut
70
71     my ( $self, $config ) = @_;
72     
73     for my $arg ( qw[ schema name comments ] ) {
74         next unless defined $config->{ $arg };
75         defined $self->$arg( $config->{ $arg } ) or return;
76     }
77
78     return $self;
79 }
80
81 # ----------------------------------------------------------------------
82 sub add_constraint {
83
84 =pod
85
86 =head2 add_constraint
87
88 Add a constraint to the table.  Returns the newly created 
89 C<SQL::Translator::Schema::Constraint> object.
90
91   my $c1 = $table->add_constraint(
92       name        => 'pk',
93       type        => PRIMARY_KEY,
94       fields      => [ 'foo_id' ],
95   );
96
97   my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' );
98   $c2    = $table->add_constraint( $constraint );
99
100 =cut
101
102     my $self             = shift;
103     my $constraint_class = 'SQL::Translator::Schema::Constraint';
104     my $constraint;
105
106     if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) {
107         $constraint = shift;
108         $constraint->table( $self );
109     }
110     else {
111         my %args = @_;
112         $args{'table'} = $self;
113         $constraint = $constraint_class->new( \%args ) or 
114             return $self->error( $constraint_class->error );
115     }
116
117     #
118     # If we're trying to add a PK when one is already defined,
119     # then just add the fields to the existing definition.
120     #
121     my $ok = 1;
122     my $pk = $self->primary_key;
123     if ( $pk && $constraint->type eq PRIMARY_KEY ) {
124         $self->primary_key( $constraint->fields );
125         $constraint = $pk;
126         $ok         = 0;
127     }
128     #
129     # See if another constraint of the same type 
130     # covers the same fields.
131     #
132     elsif ( $constraint->type ne CHECK_C ) {
133         my @field_names = $constraint->fields;
134         for my $c ( 
135             grep { $_->type eq $constraint->type } 
136             $self->get_constraints 
137         ) {
138             my %fields = map { $_, 1 } $c->fields;
139             for my $field_name ( @field_names ) {
140                 if ( $fields{ $field_name } ) {
141                     $constraint = $c;
142                     $ok = 0; 
143                     last;
144                 }
145             }
146             last unless $ok;
147         }
148     }
149
150     if ( $ok ) {
151         push @{ $self->{'constraints'} }, $constraint;
152     }
153
154     return $constraint;
155 }
156
157 # ----------------------------------------------------------------------
158 sub add_index {
159
160 =pod
161
162 =head2 add_index
163
164 Add an index to the table.  Returns the newly created
165 C<SQL::Translator::Schema::Index> object.
166
167   my $i1 = $table->add_index(
168       name   => 'name',
169       fields => [ 'name' ],
170       type   => 'normal',
171   );
172
173   my $i2 = SQL::Translator::Schema::Index->new( name => 'id' );
174   $i2    = $table->add_index( $index );
175
176 =cut
177
178     my $self        = shift;
179     my $index_class = 'SQL::Translator::Schema::Index';
180     my $index;
181
182     if ( UNIVERSAL::isa( $_[0], $index_class ) ) {
183         $index = shift;
184         $index->table( $self );
185     }
186     else {
187         my %args = @_;
188         $args{'table'} = $self;
189         $index = $index_class->new( \%args ) or return 
190             $self->error( $index_class->error );
191     }
192
193     push @{ $self->{'indices'} }, $index;
194     return $index;
195 }
196
197 # ----------------------------------------------------------------------
198 sub add_field {
199
200 =pod
201
202 =head2 add_field
203
204 Add an field to the table.  Returns the newly created
205 C<SQL::Translator::Schema::Field> object.  The "name" parameter is 
206 required.  If you try to create a field with the same name as an 
207 existing field, you will get an error and the field will not be created.
208
209   my $f1    =  $table->add_field(
210       name      => 'foo_id',
211       data_type => 'integer',
212       size      => 11,
213   );
214
215   my $f2 =  SQL::Translator::Schema::Field->new( 
216       name   => 'name', 
217       table  => $table,
218   );
219   $f2    = $table->add_field( $field2 ) or die $table->error;
220
221 =cut
222
223     my $self        = shift;
224     my $field_class = 'SQL::Translator::Schema::Field';
225     my $field;
226
227     if ( UNIVERSAL::isa( $_[0], $field_class ) ) {
228         $field = shift;
229         $field->table( $self );
230     }
231     else {
232         my %args = @_;
233         $args{'table'} = $self;
234         $field = $field_class->new( \%args ) or return 
235             $self->error( $field_class->error );
236     }
237
238     $field->order( ++$FIELD_ORDER );
239     my $field_name = $field->name or return $self->error('No name');
240
241     if ( exists $self->{'fields'}{ $field_name } ) { 
242         return $self->error(qq[Can't create field: "$field_name" exists]);
243     }
244     else {
245         $self->{'fields'}{ $field_name } = $field;
246     }
247
248     return $field;
249 }
250
251 # ----------------------------------------------------------------------
252 sub comments {
253
254 =pod
255
256 =head2 comments
257
258 Get or set the comments on a table.  May be called several times to 
259 set and it will accumulate the comments.  Called in an array context,
260 returns each comment individually; called in a scalar context, returns
261 all the comments joined on newlines.
262
263   $table->comments('foo');
264   $table->comments('bar');
265   print join( ', ', $table->comments ); # prints "foo, bar"
266
267 =cut
268
269     my $self     = shift;
270     my @comments = ref $_[0] ? @{ $_[0] } : @_;
271
272     for my $arg ( @comments ) {
273         $arg = $arg->[0] if ref $arg;
274         push @{ $self->{'comments'} }, $arg if defined $arg && $arg;
275     }
276
277     if ( @{ $self->{'comments'} || [] } ) {
278         return wantarray 
279             ? @{ $self->{'comments'} }
280             : join( "\n", @{ $self->{'comments'} } )
281         ;
282     } 
283     else {
284         return wantarray ? () : undef;
285     }
286 }
287
288 # ----------------------------------------------------------------------
289 sub get_constraints {
290
291 =pod
292
293 =head2 get_constraints
294
295 Returns all the constraint objects as an array or array reference.
296
297   my @constraints = $table->get_constraints;
298
299 =cut
300
301     my $self = shift;
302
303     if ( ref $self->{'constraints'} ) {
304         return wantarray 
305             ? @{ $self->{'constraints'} } : $self->{'constraints'};
306     }
307     else {
308         $self->error('No constraints');
309         return wantarray ? () : undef;
310     }
311 }
312
313 # ----------------------------------------------------------------------
314 sub get_indices {
315
316 =pod
317
318 =head2 get_indices
319
320 Returns all the index objects as an array or array reference.
321
322   my @indices = $table->get_indices;
323
324 =cut
325
326     my $self = shift;
327
328     if ( ref $self->{'indices'} ) {
329         return wantarray 
330             ? @{ $self->{'indices'} } 
331             : $self->{'indices'};
332     }
333     else {
334         $self->error('No indices');
335         return wantarray ? () : undef;
336     }
337 }
338
339 # ----------------------------------------------------------------------
340 sub get_field {
341
342 =pod
343
344 =head2 get_field
345
346 Returns a field by the name provided.
347
348   my $field = $table->get_field('foo');
349
350 =cut
351
352     my $self       = shift;
353     my $field_name = shift or return $self->error('No field name');
354     return $self->error( qq[Field "$field_name" does not exist] ) unless
355         exists $self->{'fields'}{ $field_name };
356     return $self->{'fields'}{ $field_name };
357 }
358
359 # ----------------------------------------------------------------------
360 sub get_fields {
361
362 =pod
363
364 =head2 get_fields
365
366 Returns all the field objects as an array or array reference.
367
368   my @fields = $table->get_fields;
369
370 =cut
371
372     my $self = shift;
373     my @fields = 
374         map  { $_->[1] }
375         sort { $a->[0] <=> $b->[0] }
376         map  { [ $_->order, $_ ] }
377         values %{ $self->{'fields'} || {} };
378
379     if ( @fields ) {
380         return wantarray ? @fields : \@fields;
381     }
382     else {
383         $self->error('No fields');
384         return wantarray ? () : undef;
385     }
386 }
387
388 # ----------------------------------------------------------------------
389 sub is_valid {
390
391 =pod
392
393 =head2 is_valid
394
395 Determine whether the view is valid or not.
396
397   my $ok = $view->is_valid;
398
399 =cut
400
401     my $self = shift;
402     return $self->error('No name')   unless $self->name;
403     return $self->error('No fields') unless $self->get_fields;
404
405     for my $object ( 
406         $self->get_fields, $self->get_indices, $self->get_constraints 
407     ) {
408         return $object->error unless $object->is_valid;
409     }
410
411     return 1;
412 }
413
414 # ----------------------------------------------------------------------
415 sub name {
416
417 =pod
418
419 =head2 name
420
421 Get or set the table's name.
422
423 If provided an argument, checks the schema object for a table of 
424 that name and disallows the change if one exists.
425
426   my $table_name = $table->name('foo');
427
428 =cut
429
430     my $self = shift;
431
432     if ( my $arg = shift ) {
433         if ( my $schema = $self->schema ) {
434             return $self->error( qq[Can't use table name "$arg": table exists] )
435                 if $schema->get_table( $arg );
436         }
437         $self->{'name'} = $arg;
438     }
439
440     return $self->{'name'} || '';
441 }
442
443 # ----------------------------------------------------------------------
444 sub schema {
445
446 =pod
447
448 =head2 schema
449
450 Get or set the table's schema object.
451
452   my $schema = $table->schema;
453
454 =cut
455
456     my $self = shift;
457     if ( my $arg = shift ) {
458         return $self->error('Not a schema object') unless
459             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' );
460         $self->{'schema'} = $arg;
461     }
462
463     return $self->{'schema'};
464 }
465
466 # ----------------------------------------------------------------------
467 sub primary_key {
468
469 =pod
470
471 =head2 options
472
473 Gets or sets the table's primary key(s).  Takes one or more field
474 names (as a string, list or array[ref]) as an argument.  If the field
475 names are present, it will create a new PK if none exists, or it will
476 add to the fields of an existing PK (and will unique the field names).
477 Returns the C<SQL::Translator::Schema::Constraint> object representing
478 the primary key.
479
480 These are eqivalent:
481
482   $table->primary_key('id');
483   $table->primary_key(['name']);
484   $table->primary_key('id','name']);
485   $table->primary_key(['id','name']);
486   $table->primary_key('id,name');
487   $table->primary_key(qw[ id name ]);
488
489   my $pk = $table->primary_key;
490
491 =cut
492
493     my $self   = shift;
494     my $fields = parse_list_arg( @_ );
495
496     my $constraint;
497     if ( @$fields ) {
498         for my $f ( @$fields ) {
499             return $self->error(qq[Invalid field "$f"]) unless 
500                 $self->get_field($f);
501         }
502
503         my $has_pk;
504         for my $c ( $self->get_constraints ) {
505             if ( $c->type eq PRIMARY_KEY ) {
506                 $has_pk = 1;
507                 $c->fields( @{ $c->fields }, @$fields );
508                 $constraint = $c;
509             } 
510         }
511
512         unless ( $has_pk ) {
513             $constraint = $self->add_constraint(
514                 type   => PRIMARY_KEY,
515                 fields => $fields,
516             ) or return;
517         }
518     }
519
520     if ( $constraint ) {
521         return $constraint;
522     }
523     else {
524         for my $c ( $self->get_constraints ) {
525             return $c if $c->type eq PRIMARY_KEY;
526         }
527     }
528
529     return;
530 }
531
532 # ----------------------------------------------------------------------
533 sub options {
534
535 =pod
536
537 =head2 options
538
539 Get or set the table's options (e.g., table types for MySQL).  Returns
540 an array or array reference.
541
542   my @options = $table->options;
543
544 =cut
545
546     my $self    = shift;
547     my $options = parse_list_arg( @_ );
548
549     push @{ $self->{'options'} }, @$options;
550
551     if ( ref $self->{'options'} ) {
552         return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
553     }
554     else {
555         return wantarray ? () : [];
556     }
557 }
558
559 # ----------------------------------------------------------------------
560 sub order {
561
562 =pod
563
564 =head2 order
565
566 Get or set the table's order.
567
568   my $order = $table->order(3);
569
570 =cut
571
572     my ( $self, $arg ) = @_;
573
574     if ( defined $arg && $arg =~ /^\d+$/ ) {
575         $self->{'order'} = $arg;
576     }
577
578     return $self->{'order'} || 0;
579 }
580
581 # ----------------------------------------------------------------------
582 sub DESTROY {
583     my $self = shift;
584     undef $self->{'schema'}; # destroy cyclical reference
585     undef $_ for @{ $self->{'constraints'} };
586     undef $_ for @{ $self->{'indices'} };
587     undef $_ for values %{ $self->{'fields'} };
588 }
589
590 1;
591
592 # ----------------------------------------------------------------------
593
594 =pod
595
596 =head1 AUTHOR
597
598 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
599
600 =cut