lib/SQL/Translator/Schema/Field.pm

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