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