lib/SQL/Translator/Schema/Field.pm

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