lib/SQL/Translator/Schema/Field.pm

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