lib/SQL/Translator/Schema/Field.pm

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