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