Added a little to the POD to explain version dependency.
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Schema / Field.pm
1 package SQL::Translator::Schema::Field;
2
3 # ----------------------------------------------------------------------
4 # $Id: Field.pm,v 1.12 2003-08-12 22:03:59 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::Field - SQL::Translator field object
28
29 =head1 SYNOPSIS
30
31   use SQL::Translator::Schema::Field;
32   my $field = SQL::Translator::Schema::Field->new(
33       name => 'foo',
34       sql  => 'select * from foo',
35   );
36
37 =head1 DESCRIPTION
38
39 C<SQL::Translator::Schema::Field> is the field object.
40
41 =head1 METHODS
42
43 =cut
44
45 use strict;
46 use Class::Base;
47 use SQL::Translator::Schema::Constants;
48 use SQL::Translator::Utils 'parse_list_arg';
49
50 use base 'Class::Base';
51 use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
52
53 $VERSION = sprintf "%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/;
54
55 # ----------------------------------------------------------------------
56 sub init {
57
58 =pod
59
60 =head2 new
61
62 Object constructor.
63
64   my $schema = SQL::Translator::Schema::Field->new;
65
66 =cut
67
68     my ( $self, $config ) = @_;
69
70     for my $arg ( 
71         qw[ 
72             table name data_type size is_primary_key is_nullable
73             is_auto_increment default_value comments
74         ] 
75     ) {
76         next unless defined $config->{ $arg };
77         defined $self->$arg( $config->{ $arg } ) or return;
78     }
79
80     return $self;
81 }
82
83 # ----------------------------------------------------------------------
84 sub comments {
85
86 =pod
87
88 =head2 comments
89
90 Get or set the comments on a field.  May be called several times to 
91 set and it will accumulate the comments.  Called in an array context,
92 returns each comment individually; called in a scalar context, returns
93 all the comments joined on newlines.
94
95   $field->comments('foo');
96   $field->comments('bar');
97   print join( ', ', $field->comments ); # prints "foo, bar"
98
99 =cut
100
101     my $self = shift;
102
103     for my $arg ( @_ ) {
104         $arg = $arg->[0] if ref $arg;
105         push @{ $self->{'comments'} }, $arg if $arg;
106     }
107
108     if ( @{ $self->{'comments'} || [] } ) {
109         return wantarray 
110             ? @{ $self->{'comments'} || [] }
111             : join( "\n", @{ $self->{'comments'} || [] } );
112     }
113     else {
114         return wantarray ? () : '';
115     }
116 }
117
118
119 # ----------------------------------------------------------------------
120 sub data_type {
121
122 =pod
123
124 =head2 data_type
125
126 Get or set the field's data type.
127
128   my $data_type = $field->data_type('integer');
129
130 =cut
131
132     my $self = shift;
133     $self->{'data_type'} = shift if @_;
134     return $self->{'data_type'} || '';
135 }
136
137 # ----------------------------------------------------------------------
138 sub default_value {
139
140 =pod
141
142 =head2 default_value
143
144 Get or set the field's default value.  Will return undef if not defined
145 and could return the empty string (it's a valid default value), so don't 
146 assume an error like other methods.
147
148   my $default = $field->default_value('foo');
149
150 =cut
151
152     my ( $self, $arg ) = @_;
153     $self->{'default_value'} = $arg if defined $arg;
154     return $self->{'default_value'};
155 }
156
157 # ----------------------------------------------------------------------
158 sub extra {
159
160 =pod
161
162 =head2 extra
163
164 Get or set the field's "extra" attibutes (e.g., "ZEROFILL" for MySQL).
165 Accepts a hash(ref) of name/value pairs to store;  returns a hash.
166
167   $field->extra( qualifier => 'ZEROFILL' );
168   my %extra = $field->extra;
169
170 =cut
171
172     my $self = shift;
173     my $args = ref $_[0] eq 'HASH' ? shift : { @_ };
174
175     while ( my ( $key, $value ) = each %$args ) {
176         $self->{'extra'}{ $key } = $value;
177     }
178
179     return %{ $self->{'extra'} || {} };
180 }
181
182 # ----------------------------------------------------------------------
183 sub foreign_key_reference {
184
185 =pod
186
187 =head2 foreign_key_reference
188
189 Get or set the field's foreign key reference;
190
191   my $constraint = $field->foreign_key_reference( $constraint );
192
193 =cut
194
195     my $self = shift;
196
197     if ( my $arg = shift ) {
198         my $class = 'SQL::Translator::Schema::Constraint';
199         if ( UNIVERSAL::isa( $arg, $class ) ) {
200             return $self->error(
201                 'Foreign key reference for ', $self->name, 'already defined'
202             ) if $self->{'foreign_key_reference'};
203
204             $self->{'foreign_key_reference'} = $arg;
205         }
206         else {
207             return $self->error(
208                 "Argument to foreign_key_reference is not an $class object"
209             );
210         }
211     }
212
213     return $self->{'foreign_key_reference'};
214 }
215
216 # ----------------------------------------------------------------------
217 sub is_auto_increment {
218
219 =pod
220
221 =head2 is_auto_increment
222
223 Get or set the field's C<is_auto_increment> attribute.
224
225   my $is_pk = $field->is_auto_increment(1);
226
227 =cut
228
229     my ( $self, $arg ) = @_;
230
231     if ( defined $arg ) {
232         $self->{'is_auto_increment'} = $arg ? 1 : 0;
233     }
234
235     unless ( defined $self->{'is_auto_increment'} ) {
236         if ( my $table = $self->table ) {
237             if ( my $schema = $table->schema ) {
238                 if ( 
239                     $schema->database eq 'PostgreSQL' &&
240                     $self->data_type eq 'serial'
241                 ) {
242                     $self->{'is_auto_increment'} = 1;
243                 }
244             }
245         }
246     }
247
248     return $self->{'is_auto_increment'} || 0;
249 }
250
251 # ----------------------------------------------------------------------
252 sub is_foreign_key {
253
254 =pod
255
256 =head2 is_foreign_key
257
258 Returns whether or not the field is a foreign key.
259
260   my $is_fk = $field->is_foreign_key;
261
262 =cut
263
264     my ( $self, $arg ) = @_;
265
266     unless ( defined $self->{'is_foreign_key'} ) {
267         if ( my $table = $self->table ) {
268             for my $c ( $table->get_constraints ) {
269                 if ( $c->type eq FOREIGN_KEY ) {
270                     my %fields = map { $_, 1 } $c->fields;
271                     if ( $fields{ $self->name } ) {
272                         $self->{'is_foreign_key'} = 1;
273                         $self->foreign_key_reference( $c );
274                         last;
275                     }
276                 }
277             }
278         }
279     }
280
281     return $self->{'is_foreign_key'} || 0;
282 }
283
284 # ----------------------------------------------------------------------
285 sub is_nullable {
286
287 =pod
288
289 =head2 is_nullable
290
291 Get or set the whether the field can be null.  If not defined, then 
292 returns "1" (assumes the field can be null).  The argument is evaluated
293 by Perl for True or False, so the following are eqivalent:
294
295   $is_nullable = $field->is_nullable(0);
296   $is_nullable = $field->is_nullable('');
297   $is_nullable = $field->is_nullable('0');
298
299 While this is technically a field constraint, it's probably easier to
300 represent this as an attribute of the field.  In order keep things
301 consistent, any other constraint on the field (unique, primary, and
302 foreign keys; checks) are represented as table constraints.
303
304 =cut
305
306     my ( $self, $arg ) = @_;
307
308     if ( defined $arg ) {
309         $self->{'is_nullable'} = $arg ? 1 : 0;
310     }
311
312     if ( 
313         defined $self->{'is_nullable'} && 
314         $self->{'is_nullable'} == 1    &&
315         $self->is_primary_key
316     ) {
317         $self->{'is_nullable'} = 0;
318     }
319
320     return defined $self->{'is_nullable'} ? $self->{'is_nullable'} : 1;
321 }
322
323 # ----------------------------------------------------------------------
324 sub is_primary_key {
325
326 =pod
327
328 =head2 is_primary_key
329
330 Get or set the field's C<is_primary_key> attribute.  Does not create
331 a table constraint (should it?).
332
333   my $is_pk = $field->is_primary_key(1);
334
335 =cut
336
337     my ( $self, $arg ) = @_;
338
339     if ( defined $arg ) {
340         $self->{'is_primary_key'} = $arg ? 1 : 0;
341     }
342
343     unless ( defined $self->{'is_primary_key'} ) {
344         if ( my $table = $self->table ) {
345             if ( my $pk = $table->primary_key ) {
346                 my %fields = map { $_, 1 } $pk->fields;
347                 $self->{'is_primary_key'} = $fields{ $self->name } || 0;
348             }
349             else {
350                 $self->{'is_primary_key'} = 0;
351             }
352         }
353     }
354
355     return $self->{'is_primary_key'} || 0;
356 }
357
358 # ----------------------------------------------------------------------
359 sub is_unique {
360
361 =pod
362
363 =head2 is_unique
364
365 Determine whether the field has a UNIQUE constraint or not.
366
367   my $is_unique = $field->is_unique;
368
369 =cut
370
371     my $self = shift;
372     
373     unless ( defined $self->{'is_unique'} ) {
374         if ( my $table = $self->table ) {
375             for my $c ( $table->get_constraints ) {
376                 if ( $c->type eq UNIQUE ) {
377                     my %fields = map { $_, 1 } $c->fields;
378                     if ( $fields{ $self->name } ) {
379                         $self->{'is_unique'} = 1;
380                         last;
381                     }
382                 }
383             }
384         }
385     }
386
387     return $self->{'is_unique'} || 0;
388 }
389
390 # ----------------------------------------------------------------------
391 sub is_valid {
392
393 =pod
394
395 =head2 is_valid
396
397 Determine whether the field is valid or not.
398
399   my $ok = $field->is_valid;
400
401 =cut
402
403     my $self = shift;
404     return $self->error('No name')         unless $self->name;
405     return $self->error('No data type')    unless $self->data_type;
406     return $self->error('No table object') unless $self->table;
407     return 1;
408 }
409
410 # ----------------------------------------------------------------------
411 sub name {
412
413 =pod
414
415 =head2 name
416
417 Get or set the field's name.
418
419   my $name = $field->name('foo');
420
421 =cut
422
423     my $self = shift;
424
425     if ( my $arg = shift ) {
426         if ( my $table = $self->table ) {
427             return $self->error( qq[Can't use field name "$arg": table exists] )
428                 if $table->get_field( $arg );
429         }
430
431         $self->{'name'} = $arg;
432     }
433
434     return $self->{'name'} || '';
435 }
436
437 # ----------------------------------------------------------------------
438 sub order {
439
440 =pod
441
442 =head2 order
443
444 Get or set the field's order.
445
446   my $order = $field->order(3);
447
448 =cut
449
450     my ( $self, $arg ) = @_;
451
452     if ( defined $arg && $arg =~ /^\d+$/ ) {
453         $self->{'order'} = $arg;
454     }
455
456     return $self->{'order'} || 0;
457 }
458
459 # ----------------------------------------------------------------------
460 sub size {
461
462 =pod
463
464 =head2 size
465
466 Get or set the field's size.  Accepts a string, array or arrayref of
467 numbers and returns a string.
468
469   $field->size( 30 );
470   $field->size( [ 255 ] );
471   $size = $field->size( 10, 2 );
472   print $size; # prints "10,2"
473
474   $size = $field->size( '10, 2' );
475   print $size; # prints "10,2"
476
477 =cut
478
479     my $self    = shift;
480     my $numbers = parse_list_arg( @_ );
481
482     if ( @$numbers ) {
483         my @new;
484         for my $num ( @$numbers ) {
485             if ( defined $num && $num =~ m/^\d+(?:\.\d+)?$/ ) {
486                 push @new, $num;
487             }
488         }
489         $self->{'size'} = \@new if @new; # only set if all OK
490     }
491
492     return wantarray 
493         ? @{ $self->{'size'} || [0] }
494         : join( ',', @{ $self->{'size'} || [0] } )
495     ;
496 }
497
498 # ----------------------------------------------------------------------
499 sub table {
500
501 =pod
502
503 =head2 table
504
505 Get or set the field's table object.
506
507   my $table = $field->table;
508
509 =cut
510
511     my $self = shift;
512     if ( my $arg = shift ) {
513         return $self->error('Not a table object') unless
514             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
515         $self->{'table'} = $arg;
516     }
517
518     return $self->{'table'};
519 }
520
521 # ----------------------------------------------------------------------
522 sub DESTROY {
523 #
524 # Destroy cyclical references.
525 #
526     my $self = shift;
527     undef $self->{'table'};
528     undef $self->{'foreign_key_reference'};
529 }
530
531 1;
532
533 # ----------------------------------------------------------------------
534
535 =pod
536
537 =head1 AUTHOR
538
539 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
540
541 =cut