lib/SQL/Translator/Schema/Field.pm

   1 package SQL::Translator::Schema::Field;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Field.pm,v 1.20 2004-11-04 16:29:56 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 SQL::Translator::Schema::Constants;
  47 use SQL::Translator::Utils 'parse_list_arg';
  48
  49 use base 'SQL::Translator::Schema::Object';
  50
  51 use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
  52
  53 $VERSION = sprintf "%d.%02d", q$Revision: 1.20 $ =~ /(\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 extra
  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 schema {
 493
 494 =head2 schema
 495
 496 Shortcut to get the fields schema ($field->table->schema) or undef if it
 497 doesn't have one.
 498
 499   my $schema = $field->schema;
 500
 501 =cut
 502
 503     my $self = shift;
 504     if ( my $table = $self->table ) { return $table->schema || undef; }
 505     return undef;
 506 }
 507
 508 # ----------------------------------------------------------------------
 509 sub size {
 510
 511 =pod
 512
 513 =head2 size
 514
 515 Get or set the field's size.  Accepts a string, array or arrayref of
 516 numbers and returns a string.
 517
 518   $field->size( 30 );
 519   $field->size( [ 255 ] );
 520   $size = $field->size( 10, 2 );
 521   print $size; # prints "10,2"
 522
 523   $size = $field->size( '10, 2' );
 524   print $size; # prints "10,2"
 525
 526 =cut
 527
 528     my $self    = shift;
 529     my $numbers = parse_list_arg( @_ );
 530
 531     if ( @$numbers ) {
 532         my @new;
 533         for my $num ( @$numbers ) {
 534             if ( defined $num && $num =~ m/^\d+(?:\.\d+)?$/ ) {
 535                 push @new, $num;
 536             }
 537         }
 538         $self->{'size'} = \@new if @new; # only set if all OK
 539     }
 540
 541     return wantarray
 542         ? @{ $self->{'size'} || [0] }
 543         : join( ',', @{ $self->{'size'} || [0] } )
 544     ;
 545 }
 546
 547 # ----------------------------------------------------------------------
 548 sub table {
 549
 550 =pod
 551
 552 =head2 table
 553
 554 Get or set the field's table object. As the table object stringifies this can
 555 also be used to get the table name.
 556
 557   my $table = $field->table;
 558   print "Table name: $table";
 559
 560 =cut
 561
 562     my $self = shift;
 563     if ( my $arg = shift ) {
 564         return $self->error('Not a table object') unless
 565             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
 566         $self->{'table'} = $arg;
 567     }
 568
 569     return $self->{'table'};
 570 }
 571
 572 # ----------------------------------------------------------------------
 573 sub DESTROY {
 574 #
 575 # Destroy cyclical references.
 576 #
 577     my $self = shift;
 578     undef $self->{'table'};
 579     undef $self->{'foreign_key_reference'};
 580 }
 581
 582 1;
 583
 584 # ----------------------------------------------------------------------
 585
 586 =pod
 587
 588 =head1 AUTHOR
 589
 590 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 591
 592 =cut