lib/SQL/Translator/Schema/Field.pm

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