lib/SQL/Translator/Schema/Field.pm

   1 package SQL::Translator::Schema::Field;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Field.pm,v 1.8 2003-06-09 02:10: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 = 1.00;
  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;
 106     }
 107
 108     return wantarray
 109         ? @{ $self->{'comments'} || [] }
 110         : join( "\n", @{ $self->{'comments'} || [] } );
 111 }
 112
 113
 114 # ----------------------------------------------------------------------
 115 sub data_type {
 116
 117 =pod
 118
 119 =head2 data_type
 120
 121 Get or set the field's data type.
 122
 123   my $data_type = $field->data_type('integer');
 124
 125 =cut
 126
 127     my $self = shift;
 128     $self->{'data_type'} = shift if @_;
 129     return $self->{'data_type'} || '';
 130 }
 131
 132 # ----------------------------------------------------------------------
 133 sub default_value {
 134
 135 =pod
 136
 137 =head2 default_value
 138
 139 Get or set the field's default value.  Will return undef if not defined
 140 and could return the empty string (it's a valid default value), so don't
 141 assume an error like other methods.
 142
 143   my $default = $field->default_value('foo');
 144
 145 =cut
 146
 147     my ( $self, $arg ) = @_;
 148     $self->{'default_value'} = $arg if defined $arg;
 149     return $self->{'default_value'};
 150 }
 151
 152 # ----------------------------------------------------------------------
 153 sub extra {
 154
 155 =pod
 156
 157 =head2 extra
 158
 159 Get or set the field's "extra" attibutes (e.g., "ZEROFILL" for MySQL).
 160 Accepts a hash(ref) of name/value pairs to store;  returns a hash.
 161
 162   $field->extra( qualifier => 'ZEROFILL' );
 163   my %extra = $field->extra;
 164
 165 =cut
 166
 167     my $self = shift;
 168     my $args = ref $_[0] eq 'HASH' ? shift : { @_ };
 169
 170     while ( my ( $key, $value ) = each %$args ) {
 171         $self->{'extra'}{ $key } = $value;
 172     }
 173
 174     return %{ $self->{'extra'} || {} };
 175 }
 176
 177 # ----------------------------------------------------------------------
 178 sub foreign_key_reference {
 179
 180 =pod
 181
 182 =head2 foreign_key_reference
 183
 184 Get or set the field's foreign key reference;
 185
 186   my $constraint = $field->foreign_key_reference( $constraint );
 187
 188 =cut
 189
 190     my $self = shift;
 191
 192     if ( my $arg = shift ) {
 193         my $class = 'SQL::Translator::Schema::Constraint';
 194         if ( UNIVERSAL::isa( $arg, $class ) ) {
 195             return $self->error(
 196                 'Foreign key reference for ', $self->name, 'already defined'
 197             ) if $self->{'foreign_key_reference'};
 198
 199             $self->{'foreign_key_reference'} = $arg;
 200         }
 201         else {
 202             return $self->error(
 203                 "Argument to foreign_key_reference is not an $class object"
 204             );
 205         }
 206     }
 207
 208     return $self->{'foreign_key_reference'};
 209 }
 210
 211 # ----------------------------------------------------------------------
 212 sub is_auto_increment {
 213
 214 =pod
 215
 216 =head2 is_auto_increment
 217
 218 Get or set the field's C<is_auto_increment> attribute.
 219
 220   my $is_pk = $field->is_auto_increment(1);
 221
 222 =cut
 223
 224     my ( $self, $arg ) = @_;
 225
 226     if ( defined $arg ) {
 227         $self->{'is_auto_increment'} = $arg ? 1 : 0;
 228     }
 229
 230     unless ( defined $self->{'is_auto_increment'} ) {
 231         if ( my $table = $self->table ) {
 232             if ( my $schema = $table->schema ) {
 233                 if (
 234                     $schema->database eq 'PostgreSQL' &&
 235                     $self->data_type eq 'serial'
 236                 ) {
 237                     $self->{'is_auto_increment'} = 1;
 238                 }
 239             }
 240         }
 241     }
 242
 243     return $self->{'is_auto_increment'} || 0;
 244 }
 245
 246 # ----------------------------------------------------------------------
 247 sub is_foreign_key {
 248
 249 =pod
 250
 251 =head2 is_foreign_key
 252
 253 Returns whether or not the field is a foreign key.
 254
 255   my $is_fk = $field->is_foreign_key;
 256
 257 =cut
 258
 259     my ( $self, $arg ) = @_;
 260
 261     unless ( defined $self->{'is_foreign_key'} ) {
 262         if ( my $table = $self->table ) {
 263             for my $c ( $table->get_constraints ) {
 264                 if ( $c->type eq FOREIGN_KEY ) {
 265                     my %fields = map { $_, 1 } $c->fields;
 266                     if ( $fields{ $self->name } ) {
 267                         $self->{'is_foreign_key'} = 1;
 268                         $self->foreign_key_reference( $c );
 269                         last;
 270                     }
 271                 }
 272             }
 273         }
 274     }
 275
 276     return $self->{'is_foreign_key'} || 0;
 277 }
 278
 279
 280 # ----------------------------------------------------------------------
 281 sub is_nullable {
 282
 283 =pod
 284
 285 =head2 is_nullable
 286
 287 Get or set the whether the field can be null.  If not defined, then
 288 returns "1" (assumes the field can be null).  The argument is evaluated
 289 by Perl for True or False, so the following are eqivalent:
 290
 291   $is_nullable = $field->is_nullable(0);
 292   $is_nullable = $field->is_nullable('');
 293   $is_nullable = $field->is_nullable('0');
 294
 295 While this is technically a field constraint, it's probably easier to
 296 represent this as an attribute of the field.  In order keep things
 297 consistent, any other constraint on the field (unique, primary, and
 298 foreign keys; checks) are represented as table constraints.
 299
 300 =cut
 301
 302     my ( $self, $arg ) = @_;
 303
 304     if ( defined $arg ) {
 305         $self->{'is_nullable'} = $arg ? 1 : 0;
 306     }
 307
 308     return defined $self->{'is_nullable'} ? $self->{'is_nullable'} : 1;
 309 }
 310
 311 # ----------------------------------------------------------------------
 312 sub is_primary_key {
 313
 314 =pod
 315
 316 =head2 is_primary_key
 317
 318 Get or set the field's C<is_primary_key> attribute.  Does not create
 319 a table constraint (should it?).
 320
 321   my $is_pk = $field->is_primary_key(1);
 322
 323 =cut
 324
 325     my ( $self, $arg ) = @_;
 326
 327     if ( defined $arg ) {
 328         $self->{'is_primary_key'} = $arg ? 1 : 0;
 329     }
 330
 331     unless ( defined $self->{'is_primary_key'} ) {
 332         if ( my $table = $self->table ) {
 333             if ( my $pk = $table->primary_key ) {
 334                 my %fields = map { $_, 1 } $pk->fields;
 335                 $self->{'is_primary_key'} = $fields{ $self->name } || 0;
 336             }
 337             else {
 338                 $self->{'is_primary_key'} = 0;
 339             }
 340         }
 341     }
 342
 343     return $self->{'is_primary_key'} || 0;
 344 }
 345
 346 # ----------------------------------------------------------------------
 347 sub is_valid {
 348
 349 =pod
 350
 351 =head2 is_valid
 352
 353 Determine whether the field is valid or not.
 354
 355   my $ok = $field->is_valid;
 356
 357 =cut
 358
 359     my $self = shift;
 360     return $self->error('No name')         unless $self->name;
 361     return $self->error('No data type')    unless $self->data_type;
 362     return $self->error('No table object') unless $self->table;
 363     return 1;
 364 }
 365
 366 # ----------------------------------------------------------------------
 367 sub name {
 368
 369 =pod
 370
 371 =head2 name
 372
 373 Get or set the field's name.
 374
 375   my $name = $field->name('foo');
 376
 377 =cut
 378
 379     my $self = shift;
 380
 381     if ( my $arg = shift ) {
 382         if ( my $table = $self->table ) {
 383             return $self->error( qq[Can't use field name "$arg": table exists] )
 384                 if $table->get_field( $arg );
 385         }
 386
 387         $self->{'name'} = $arg;
 388     }
 389
 390     return $self->{'name'} || '';
 391 }
 392
 393 # ----------------------------------------------------------------------
 394 sub order {
 395
 396 =pod
 397
 398 =head2 order
 399
 400 Get or set the field's order.
 401
 402   my $order = $field->order(3);
 403
 404 =cut
 405
 406     my ( $self, $arg ) = @_;
 407
 408     if ( defined $arg && $arg =~ /^\d+$/ ) {
 409         $self->{'order'} = $arg;
 410     }
 411
 412     return $self->{'order'} || 0;
 413 }
 414
 415 # ----------------------------------------------------------------------
 416 sub size {
 417
 418 =pod
 419
 420 =head2 size
 421
 422 Get or set the field's size.  Accepts a string, array or arrayref of
 423 numbers and returns a string.
 424
 425   $field->size( 30 );
 426   $field->size( [ 255 ] );
 427   $size = $field->size( 10, 2 );
 428   print $size; # prints "10,2"
 429
 430   $size = $field->size( '10, 2' );
 431   print $size; # prints "10,2"
 432
 433 =cut
 434
 435     my $self    = shift;
 436     my $numbers = parse_list_arg( @_ );
 437
 438     if ( @$numbers ) {
 439         my @new;
 440         for my $num ( @$numbers ) {
 441             if ( defined $num && $num =~ m/^\d+(?:\.\d+)?$/ ) {
 442                 push @new, $num;
 443             }
 444         }
 445         $self->{'size'} = \@new if @new; # only set if all OK
 446     }
 447
 448     return wantarray
 449         ? @{ $self->{'size'} || [0] }
 450         : join( ',', @{ $self->{'size'} || [0] } )
 451     ;
 452 }
 453
 454 # ----------------------------------------------------------------------
 455 sub table {
 456
 457 =pod
 458
 459 =head2 table
 460
 461 Get or set the field's table object.
 462
 463   my $table = $field->table;
 464
 465 =cut
 466
 467     my $self = shift;
 468     if ( my $arg = shift ) {
 469         return $self->error('Not a table object') unless
 470             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
 471         $self->{'table'} = $arg;
 472     }
 473
 474     return $self->{'table'};
 475 }
 476
 477 # ----------------------------------------------------------------------
 478 sub DESTROY {
 479 #
 480 # Destroy cyclical references.
 481 #
 482     my $self = shift;
 483     undef $self->{'table'};
 484     undef $self->{'foreign_key_reference'};
 485 }
 486
 487 1;
 488
 489 # ----------------------------------------------------------------------
 490
 491 =pod
 492
 493 =head1 AUTHOR
 494
 495 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 496
 497 =cut