lib/SQL/Translator/Schema/Field.pm

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