lib/SQL/Translator/Schema/Field.pm

   1 package SQL::Translator::Schema::Field;
   2
   3 # ----------------------------------------------------------------------
   4 # Copyright (C) 2002-2009 SQLFairy Authors
   5 #
   6 # This program is free software; you can redistribute it and/or
   7 # modify it under the terms of the GNU General Public License as
   8 # published by the Free Software Foundation; version 2.
   9 #
  10 # This program is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  18 # 02111-1307  USA
  19 # -------------------------------------------------------------------
  20
  21 =pod
  22
  23 =head1 NAME
  24
  25 SQL::Translator::Schema::Field - SQL::Translator field object
  26
  27 =head1 SYNOPSIS
  28
  29   use SQL::Translator::Schema::Field;
  30   my $field = SQL::Translator::Schema::Field->new(
  31       name  => 'foo',
  32       table => $table,
  33   );
  34
  35 =head1 DESCRIPTION
  36
  37 C<SQL::Translator::Schema::Field> is the field object.
  38
  39 =head1 METHODS
  40
  41 =cut
  42
  43 use strict;
  44 use SQL::Translator::Schema::Constants;
  45 use SQL::Translator::Utils 'parse_list_arg';
  46
  47 use base 'SQL::Translator::Schema::Object';
  48
  49 use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
  50
  51 $VERSION = '1.59';
  52
  53 # Stringify to our name, being careful not to pass any args through so we don't
  54 # accidentally set it to undef. We also have to tweak bool so the object is
  55 # still true when it doesn't have a name (which shouldn't happen!).
  56 use overload
  57     '""'     => sub { shift->name },
  58     'bool'   => sub { $_[0]->name || $_[0] },
  59     fallback => 1,
  60 ;
  61
  62 use DBI qw(:sql_types);
  63
  64 # Mapping from string to sql contstant
  65 our %type_mapping = (
  66   integer => SQL_INTEGER,
  67   int     => SQL_INTEGER,
  68
  69   smallint => SQL_SMALLINT,
  70   bigint => 9999, # DBI doesn't export a constatn for this. Le suck
  71
  72   double => SQL_DOUBLE,
  73
  74   decimal => SQL_DECIMAL,
  75   numeric => SQL_NUMERIC,
  76   dec => SQL_DECIMAL,
  77
  78   bit => SQL_BIT,
  79
  80   date => SQL_DATE,
  81   datetime => SQL_DATETIME,
  82   timestamp => SQL_TIMESTAMP,
  83   time => SQL_TIME,
  84
  85   char => SQL_CHAR,
  86   varchar => SQL_VARCHAR,
  87   binary => SQL_BINARY,
  88   varbinary => SQL_VARBINARY,
  89   tinyblob => SQL_BLOB,
  90   blob => SQL_BLOB,
  91   text => SQL_LONGVARCHAR
  92
  93 );
  94 # ----------------------------------------------------------------------
  95
  96 __PACKAGE__->_attributes( qw/
  97     table name data_type size is_primary_key is_nullable
  98     is_auto_increment default_value comments is_foreign_key
  99     is_unique order sql_data_type
 100 /);
 101
 102 =pod
 103
 104 =head2 new
 105
 106 Object constructor.
 107
 108   my $field = SQL::Translator::Schema::Field->new(
 109       name  => 'foo',
 110       table => $table,
 111   );
 112
 113 =cut
 114
 115 # ----------------------------------------------------------------------
 116 sub comments {
 117
 118 =pod
 119
 120 =head2 comments
 121
 122 Get or set the comments on a field.  May be called several times to
 123 set and it will accumulate the comments.  Called in an array context,
 124 returns each comment individually; called in a scalar context, returns
 125 all the comments joined on newlines.
 126
 127   $field->comments('foo');
 128   $field->comments('bar');
 129   print join( ', ', $field->comments ); # prints "foo, bar"
 130
 131 =cut
 132
 133     my $self = shift;
 134
 135     for my $arg ( @_ ) {
 136         $arg = $arg->[0] if ref $arg;
 137         push @{ $self->{'comments'} }, $arg if $arg;
 138     }
 139
 140     if ( @{ $self->{'comments'} || [] } ) {
 141         return wantarray
 142             ? @{ $self->{'comments'} || [] }
 143             : join( "\n", @{ $self->{'comments'} || [] } );
 144     }
 145     else {
 146         return wantarray ? () : '';
 147     }
 148 }
 149
 150
 151 # ----------------------------------------------------------------------
 152 sub data_type {
 153
 154 =pod
 155
 156 =head2 data_type
 157
 158 Get or set the field's data type.
 159
 160   my $data_type = $field->data_type('integer');
 161
 162 =cut
 163
 164     my $self = shift;
 165     if (@_) {
 166       $self->{'data_type'} = $_[0];
 167       $self->{'sql_data_type'} = $type_mapping{lc $_[0]} || SQL_UNKNOWN_TYPE unless exists $self->{sql_data_type};
 168     }
 169     return $self->{'data_type'} || '';
 170 }
 171
 172 sub sql_data_type {
 173
 174 =head2 sql_data_type
 175
 176 Constant from DBI package representing this data type. See L<DBI/DBI Constants>
 177 for more details.
 178
 179 =cut
 180
 181     my $self = shift;
 182     $self->{sql_data_type} = shift if @_;
 183     return $self->{sql_data_type} || 0;
 184
 185 }
 186
 187 # ----------------------------------------------------------------------
 188 sub default_value {
 189
 190 =pod
 191
 192 =head2 default_value
 193
 194 Get or set the field's default value.  Will return undef if not defined
 195 and could return the empty string (it's a valid default value), so don't
 196 assume an error like other methods.
 197
 198   my $default = $field->default_value('foo');
 199
 200 =cut
 201
 202     my ( $self, $arg ) = @_;
 203     $self->{'default_value'} = $arg if defined $arg;
 204     return $self->{'default_value'};
 205 }
 206
 207 # ----------------------------------------------------------------------
 208 =pod
 209
 210 =head2 extra
 211
 212 Get or set the field's "extra" attibutes (e.g., "ZEROFILL" for MySQL).
 213 Accepts a hash(ref) of name/value pairs to store;  returns a hash.
 214
 215   $field->extra( qualifier => 'ZEROFILL' );
 216   my %extra = $field->extra;
 217
 218 =cut
 219
 220
 221 # ----------------------------------------------------------------------
 222 sub foreign_key_reference {
 223
 224 =pod
 225
 226 =head2 foreign_key_reference
 227
 228 Get or set the field's foreign key reference;
 229
 230   my $constraint = $field->foreign_key_reference( $constraint );
 231
 232 =cut
 233
 234     my $self = shift;
 235
 236     if ( my $arg = shift ) {
 237         my $class = 'SQL::Translator::Schema::Constraint';
 238         if ( UNIVERSAL::isa( $arg, $class ) ) {
 239             return $self->error(
 240                 'Foreign key reference for ', $self->name, 'already defined'
 241             ) if $self->{'foreign_key_reference'};
 242
 243             $self->{'foreign_key_reference'} = $arg;
 244         }
 245         else {
 246             return $self->error(
 247                 "Argument to foreign_key_reference is not an $class object"
 248             );
 249         }
 250     }
 251
 252     return $self->{'foreign_key_reference'};
 253 }
 254
 255 # ----------------------------------------------------------------------
 256 sub is_auto_increment {
 257
 258 =pod
 259
 260 =head2 is_auto_increment
 261
 262 Get or set the field's C<is_auto_increment> attribute.
 263
 264   my $is_auto = $field->is_auto_increment(1);
 265
 266 =cut
 267
 268     my ( $self, $arg ) = @_;
 269
 270     if ( defined $arg ) {
 271         $self->{'is_auto_increment'} = $arg ? 1 : 0;
 272     }
 273
 274     unless ( defined $self->{'is_auto_increment'} ) {
 275         if ( my $table = $self->table ) {
 276             if ( my $schema = $table->schema ) {
 277                 if (
 278                     $schema->database eq 'PostgreSQL' &&
 279                     $self->data_type eq 'serial'
 280                 ) {
 281                     $self->{'is_auto_increment'} = 1;
 282                 }
 283             }
 284         }
 285     }
 286
 287     return $self->{'is_auto_increment'} || 0;
 288 }
 289
 290 # ----------------------------------------------------------------------
 291 sub is_foreign_key {
 292
 293 =pod
 294
 295 =head2 is_foreign_key
 296
 297 Returns whether or not the field is a foreign key.
 298
 299   my $is_fk = $field->is_foreign_key;
 300
 301 =cut
 302
 303     my ( $self, $arg ) = @_;
 304
 305     unless ( defined $self->{'is_foreign_key'} ) {
 306         if ( my $table = $self->table ) {
 307             for my $c ( $table->get_constraints ) {
 308                 if ( $c->type eq FOREIGN_KEY ) {
 309                     my %fields = map { $_, 1 } $c->fields;
 310                     if ( $fields{ $self->name } ) {
 311                         $self->{'is_foreign_key'} = 1;
 312                         $self->foreign_key_reference( $c );
 313                         last;
 314                     }
 315                 }
 316             }
 317         }
 318     }
 319
 320     return $self->{'is_foreign_key'} || 0;
 321 }
 322
 323 # ----------------------------------------------------------------------
 324 sub is_nullable {
 325
 326 =pod
 327
 328 =head2 is_nullable
 329
 330 Get or set whether the field can be null.  If not defined, then
 331 returns "1" (assumes the field can be null).  The argument is evaluated
 332 by Perl for True or False, so the following are eqivalent:
 333
 334   $is_nullable = $field->is_nullable(0);
 335   $is_nullable = $field->is_nullable('');
 336   $is_nullable = $field->is_nullable('0');
 337
 338 While this is technically a field constraint, it's probably easier to
 339 represent this as an attribute of the field.  In order keep things
 340 consistent, any other constraint on the field (unique, primary, and
 341 foreign keys; checks) are represented as table constraints.
 342
 343 =cut
 344
 345     my ( $self, $arg ) = @_;
 346
 347     if ( defined $arg ) {
 348         $self->{'is_nullable'} = $arg ? 1 : 0;
 349     }
 350
 351     if (
 352         defined $self->{'is_nullable'} &&
 353         $self->{'is_nullable'} == 1    &&
 354         $self->is_primary_key
 355     ) {
 356         $self->{'is_nullable'} = 0;
 357     }
 358
 359     return defined $self->{'is_nullable'} ? $self->{'is_nullable'} : 1;
 360 }
 361
 362 # ----------------------------------------------------------------------
 363 sub is_primary_key {
 364
 365 =pod
 366
 367 =head2 is_primary_key
 368
 369 Get or set the field's C<is_primary_key> attribute.  Does not create
 370 a table constraint (should it?).
 371
 372   my $is_pk = $field->is_primary_key(1);
 373
 374 =cut
 375
 376     my ( $self, $arg ) = @_;
 377
 378     if ( defined $arg ) {
 379         $self->{'is_primary_key'} = $arg ? 1 : 0;
 380     }
 381
 382     unless ( defined $self->{'is_primary_key'} ) {
 383         if ( my $table = $self->table ) {
 384             if ( my $pk = $table->primary_key ) {
 385                 my %fields = map { $_, 1 } $pk->fields;
 386                 $self->{'is_primary_key'} = $fields{ $self->name } || 0;
 387             }
 388             else {
 389                 $self->{'is_primary_key'} = 0;
 390             }
 391         }
 392     }
 393
 394     return $self->{'is_primary_key'} || 0;
 395 }
 396
 397 # ----------------------------------------------------------------------
 398 sub is_unique {
 399
 400 =pod
 401
 402 =head2 is_unique
 403
 404 Determine whether the field has a UNIQUE constraint or not.
 405
 406   my $is_unique = $field->is_unique;
 407
 408 =cut
 409
 410     my $self = shift;
 411
 412     unless ( defined $self->{'is_unique'} ) {
 413         if ( my $table = $self->table ) {
 414             for my $c ( $table->get_constraints ) {
 415                 if ( $c->type eq UNIQUE ) {
 416                     my %fields = map { $_, 1 } $c->fields;
 417                     if ( $fields{ $self->name } ) {
 418                         $self->{'is_unique'} = 1;
 419                         last;
 420                     }
 421                 }
 422             }
 423         }
 424     }
 425
 426     return $self->{'is_unique'} || 0;
 427 }
 428
 429 # ----------------------------------------------------------------------
 430 sub is_valid {
 431
 432 =pod
 433
 434 =head2 is_valid
 435
 436 Determine whether the field is valid or not.
 437
 438   my $ok = $field->is_valid;
 439
 440 =cut
 441
 442     my $self = shift;
 443     return $self->error('No name')         unless $self->name;
 444     return $self->error('No data type')    unless $self->data_type;
 445     return $self->error('No table object') unless $self->table;
 446     return 1;
 447 }
 448
 449 # ----------------------------------------------------------------------
 450 sub name {
 451
 452 =pod
 453
 454 =head2 name
 455
 456 Get or set the field's name.
 457
 458  my $name = $field->name('foo');
 459
 460 The field object will also stringify to its name.
 461
 462  my $setter_name = "set_$field";
 463
 464 Errors ("No field name") if you try to set a blank name.
 465
 466 =cut
 467
 468     my $self = shift;
 469
 470     if ( @_ ) {
 471         my $arg = shift || return $self->error( "No field name" );
 472         if ( my $table = $self->table ) {
 473             return $self->error( qq[Can't use field name "$arg": field exists] )
 474                 if $table->get_field( $arg );
 475         }
 476
 477         $self->{'name'} = $arg;
 478     }
 479
 480     return $self->{'name'} || '';
 481 }
 482
 483 sub full_name {
 484
 485 =head2 full_name
 486
 487 Read only method to return the fields name with its table name pre-pended.
 488 e.g. "person.foo".
 489
 490 =cut
 491
 492     my $self = shift;
 493     return $self->table.".".$self->name;
 494 }
 495
 496 # ----------------------------------------------------------------------
 497 sub order {
 498
 499 =pod
 500
 501 =head2 order
 502
 503 Get or set the field's order.
 504
 505   my $order = $field->order(3);
 506
 507 =cut
 508
 509     my ( $self, $arg ) = @_;
 510
 511     if ( defined $arg && $arg =~ /^\d+$/ ) {
 512         $self->{'order'} = $arg;
 513     }
 514
 515     return $self->{'order'} || 0;
 516 }
 517
 518 # ----------------------------------------------------------------------
 519 sub schema {
 520
 521 =head2 schema
 522
 523 Shortcut to get the fields schema ($field->table->schema) or undef if it
 524 doesn't have one.
 525
 526   my $schema = $field->schema;
 527
 528 =cut
 529
 530     my $self = shift;
 531     if ( my $table = $self->table ) { return $table->schema || undef; }
 532     return undef;
 533 }
 534
 535 # ----------------------------------------------------------------------
 536 sub size {
 537
 538 =pod
 539
 540 =head2 size
 541
 542 Get or set the field's size.  Accepts a string, array or arrayref of
 543 numbers and returns a string.
 544
 545   $field->size( 30 );
 546   $field->size( [ 255 ] );
 547   $size = $field->size( 10, 2 );
 548   print $size; # prints "10,2"
 549
 550   $size = $field->size( '10, 2' );
 551   print $size; # prints "10,2"
 552
 553 =cut
 554
 555     my $self    = shift;
 556     my $numbers = parse_list_arg( @_ );
 557
 558     if ( @$numbers ) {
 559         my @new;
 560         for my $num ( @$numbers ) {
 561             if ( defined $num && $num =~ m/^\d+(?:\.\d+)?$/ ) {
 562                 push @new, $num;
 563             }
 564         }
 565         $self->{'size'} = \@new if @new; # only set if all OK
 566     }
 567
 568     return wantarray
 569         ? @{ $self->{'size'} || [0] }
 570         : join( ',', @{ $self->{'size'} || [0] } )
 571     ;
 572 }
 573
 574 # ----------------------------------------------------------------------
 575 sub table {
 576
 577 =pod
 578
 579 =head2 table
 580
 581 Get or set the field's table object. As the table object stringifies this can
 582 also be used to get the table name.
 583
 584   my $table = $field->table;
 585   print "Table name: $table";
 586
 587 =cut
 588
 589     my $self = shift;
 590     if ( my $arg = shift ) {
 591         return $self->error('Not a table object') unless
 592             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
 593         $self->{'table'} = $arg;
 594     }
 595
 596     return $self->{'table'};
 597 }
 598
 599 sub parsed_field {
 600
 601 =head2
 602
 603 Returns the field exactly as the parser found it
 604
 605 =cut
 606
 607     my $self = shift;
 608
 609     if (@_) {
 610       my $value = shift;
 611       $self->{parsed_field} = $value;
 612       return $value || $self;
 613     }
 614     return $self->{parsed_field} || $self;
 615 }
 616
 617 # ----------------------------------------------------------------------
 618 sub equals {
 619
 620 =pod
 621
 622 =head2 equals
 623
 624 Determines if this field is the same as another
 625
 626   my $isIdentical = $field1->equals( $field2 );
 627
 628 =cut
 629
 630     my $self = shift;
 631     my $other = shift;
 632     my $case_insensitive = shift;
 633
 634     return 0 unless $self->SUPER::equals($other);
 635     return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
 636
 637     # Comparing types: use sql_data_type if both are not 0. Else use string data_type
 638     if ($self->sql_data_type && $other->sql_data_type) {
 639         return 0 unless $self->sql_data_type == $other->sql_data_type
 640     } else {
 641         return 0 unless lc($self->data_type) eq lc($other->data_type)
 642     }
 643
 644     return 0 unless $self->size eq $other->size;
 645
 646     {
 647         my $lhs = $self->default_value;
 648            $lhs = \'NULL' unless defined $lhs;
 649         my $lhs_is_ref = ! ! ref $lhs;
 650
 651         my $rhs = $other->default_value;
 652            $rhs = \'NULL' unless defined $rhs;
 653         my $rhs_is_ref = ! ! ref $rhs;
 654
 655         # If only one is a ref, fail. -- rjbs, 2008-12-02
 656         return 0 if $lhs_is_ref xor $rhs_is_ref;
 657
 658         my $effective_lhs = $lhs_is_ref ? $$lhs : $lhs;
 659         my $effective_rhs = $rhs_is_ref ? $$rhs : $rhs;
 660
 661         return 0 if $effective_lhs ne $effective_rhs;
 662     }
 663
 664     return 0 unless $self->is_nullable eq $other->is_nullable;
 665 #    return 0 unless $self->is_unique eq $other->is_unique;
 666     return 0 unless $self->is_primary_key eq $other->is_primary_key;
 667 #    return 0 unless $self->is_foreign_key eq $other->is_foreign_key;
 668     return 0 unless $self->is_auto_increment eq $other->is_auto_increment;
 669 #    return 0 unless $self->comments eq $other->comments;
 670     return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
 671     return 1;
 672 }
 673
 674 # ----------------------------------------------------------------------
 675 sub DESTROY {
 676 #
 677 # Destroy cyclical references.
 678 #
 679     my $self = shift;
 680     undef $self->{'table'};
 681     undef $self->{'foreign_key_reference'};
 682 }
 683
 684 1;
 685
 686 # ----------------------------------------------------------------------
 687
 688 =pod
 689
 690 =head1 AUTHOR
 691
 692 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 693
 694 =cut