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