lib/SQL/Translator/Schema/Field.pm

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