lib/SQL/Translator/Schema/Field.pm

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