lib/SQL/Translator/Schema/Field.pm

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