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