lib/SQL/Translator/Schema/Field.pm

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