lib/SQL/Translator/Schema/Field.pm

   1 package SQL::Translator::Schema::Field;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Field.pm,v 1.10 2003-06-18 23:14:00 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 = (qw$Revision: 1.10 $)[-1];
  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     return defined $self->{'is_nullable'} ? $self->{'is_nullable'} : 1;
 313 }
 314
 315 # ----------------------------------------------------------------------
 316 sub is_primary_key {
 317
 318 =pod
 319
 320 =head2 is_primary_key
 321
 322 Get or set the field's C<is_primary_key> attribute.  Does not create
 323 a table constraint (should it?).
 324
 325   my $is_pk = $field->is_primary_key(1);
 326
 327 =cut
 328
 329     my ( $self, $arg ) = @_;
 330
 331     if ( defined $arg ) {
 332         $self->{'is_primary_key'} = $arg ? 1 : 0;
 333     }
 334
 335     unless ( defined $self->{'is_primary_key'} ) {
 336         if ( my $table = $self->table ) {
 337             if ( my $pk = $table->primary_key ) {
 338                 my %fields = map { $_, 1 } $pk->fields;
 339                 $self->{'is_primary_key'} = $fields{ $self->name } || 0;
 340             }
 341             else {
 342                 $self->{'is_primary_key'} = 0;
 343             }
 344         }
 345     }
 346
 347     return $self->{'is_primary_key'} || 0;
 348 }
 349
 350 # ----------------------------------------------------------------------
 351 sub is_unique {
 352
 353 =pod
 354
 355 =head2 is_unique
 356
 357 Determine whether the field has a UNIQUE constraint or not.
 358
 359   my $is_unique = $field->is_unique;
 360
 361 =cut
 362
 363     my $self = shift;
 364
 365     unless ( defined $self->{'is_unique'} ) {
 366         if ( my $table = $self->table ) {
 367             for my $c ( $table->get_constraints ) {
 368                 if ( $c->type eq UNIQUE ) {
 369                     my %fields = map { $_, 1 } $c->fields;
 370                     if ( $fields{ $self->name } ) {
 371                         $self->{'is_unique'} = 1;
 372                         last;
 373                     }
 374                 }
 375             }
 376         }
 377     }
 378
 379     return $self->{'is_unique'} || 0;
 380 }
 381
 382 # ----------------------------------------------------------------------
 383 sub is_valid {
 384
 385 =pod
 386
 387 =head2 is_valid
 388
 389 Determine whether the field is valid or not.
 390
 391   my $ok = $field->is_valid;
 392
 393 =cut
 394
 395     my $self = shift;
 396     return $self->error('No name')         unless $self->name;
 397     return $self->error('No data type')    unless $self->data_type;
 398     return $self->error('No table object') unless $self->table;
 399     return 1;
 400 }
 401
 402 # ----------------------------------------------------------------------
 403 sub name {
 404
 405 =pod
 406
 407 =head2 name
 408
 409 Get or set the field's name.
 410
 411   my $name = $field->name('foo');
 412
 413 =cut
 414
 415     my $self = shift;
 416
 417     if ( my $arg = shift ) {
 418         if ( my $table = $self->table ) {
 419             return $self->error( qq[Can't use field name "$arg": table exists] )
 420                 if $table->get_field( $arg );
 421         }
 422
 423         $self->{'name'} = $arg;
 424     }
 425
 426     return $self->{'name'} || '';
 427 }
 428
 429 # ----------------------------------------------------------------------
 430 sub order {
 431
 432 =pod
 433
 434 =head2 order
 435
 436 Get or set the field's order.
 437
 438   my $order = $field->order(3);
 439
 440 =cut
 441
 442     my ( $self, $arg ) = @_;
 443
 444     if ( defined $arg && $arg =~ /^\d+$/ ) {
 445         $self->{'order'} = $arg;
 446     }
 447
 448     return $self->{'order'} || 0;
 449 }
 450
 451 # ----------------------------------------------------------------------
 452 sub size {
 453
 454 =pod
 455
 456 =head2 size
 457
 458 Get or set the field's size.  Accepts a string, array or arrayref of
 459 numbers and returns a string.
 460
 461   $field->size( 30 );
 462   $field->size( [ 255 ] );
 463   $size = $field->size( 10, 2 );
 464   print $size; # prints "10,2"
 465
 466   $size = $field->size( '10, 2' );
 467   print $size; # prints "10,2"
 468
 469 =cut
 470
 471     my $self    = shift;
 472     my $numbers = parse_list_arg( @_ );
 473
 474     if ( @$numbers ) {
 475         my @new;
 476         for my $num ( @$numbers ) {
 477             if ( defined $num && $num =~ m/^\d+(?:\.\d+)?$/ ) {
 478                 push @new, $num;
 479             }
 480         }
 481         $self->{'size'} = \@new if @new; # only set if all OK
 482     }
 483
 484     return wantarray
 485         ? @{ $self->{'size'} || [0] }
 486         : join( ',', @{ $self->{'size'} || [0] } )
 487     ;
 488 }
 489
 490 # ----------------------------------------------------------------------
 491 sub table {
 492
 493 =pod
 494
 495 =head2 table
 496
 497 Get or set the field's table object.
 498
 499   my $table = $field->table;
 500
 501 =cut
 502
 503     my $self = shift;
 504     if ( my $arg = shift ) {
 505         return $self->error('Not a table object') unless
 506             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
 507         $self->{'table'} = $arg;
 508     }
 509
 510     return $self->{'table'};
 511 }
 512
 513 # ----------------------------------------------------------------------
 514 sub DESTROY {
 515 #
 516 # Destroy cyclical references.
 517 #
 518     my $self = shift;
 519     undef $self->{'table'};
 520     undef $self->{'foreign_key_reference'};
 521 }
 522
 523 1;
 524
 525 # ----------------------------------------------------------------------
 526
 527 =pod
 528
 529 =head1 AUTHOR
 530
 531 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 532
 533 =cut