lib/SQL/Translator/Schema/Field.pm

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