lib/SQL/Translator/Schema/Field.pm

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