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