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     weak_ref => 1,
 182 );
 183
 184 around foreign_key_reference => sub {
 185     my $orig = shift;
 186     my $self = shift;
 187
 188     if ( my $arg = shift ) {
 189         return $self->error(
 190             'Foreign key reference for ', $self->name, 'already defined'
 191         ) if $self->_has_foreign_key_reference;
 192
 193         return ex2err($orig, $self, $arg);
 194     }
 195     $self->$orig;
 196 };
 197
 198 =head2 is_auto_increment
 199
 200 Get or set the field's C<is_auto_increment> attribute.
 201
 202   my $is_auto = $field->is_auto_increment(1);
 203
 204 =cut
 205
 206 has is_auto_increment => (
 207     is => 'rw',
 208     coerce => sub { $_[0] ? 1 : 0 },
 209     builder => 1,
 210     lazy => 1,
 211 );
 212
 213 sub _build_is_auto_increment {
 214     my ( $self ) = @_;
 215
 216     if ( my $table = $self->table ) {
 217         if ( my $schema = $table->schema ) {
 218             if (
 219                 $schema->database eq 'PostgreSQL' &&
 220                 $self->data_type eq 'serial'
 221             ) {
 222                 return 1;
 223             }
 224         }
 225     }
 226     return 0;
 227 }
 228
 229 =head2 is_foreign_key
 230
 231 Returns whether or not the field is a foreign key.
 232
 233   my $is_fk = $field->is_foreign_key;
 234
 235 =cut
 236
 237 has is_foreign_key => (
 238     is => 'rw',
 239     coerce => sub { $_[0] ? 1 : 0 },
 240     builder => 1,
 241     lazy => 1,
 242 );
 243
 244 sub _build_is_foreign_key {
 245     my ( $self ) = @_;
 246
 247     if ( my $table = $self->table ) {
 248         for my $c ( $table->get_constraints ) {
 249             if ( $c->type eq FOREIGN_KEY ) {
 250                 my %fields = map { $_, 1 } $c->fields;
 251                 if ( $fields{ $self->name } ) {
 252                     $self->foreign_key_reference( $c );
 253                     return 1;
 254                 }
 255             }
 256         }
 257     }
 258     return 0;
 259 }
 260
 261 =head2 is_nullable
 262
 263 Get or set whether the field can be null.  If not defined, then
 264 returns "1" (assumes the field can be null).  The argument is evaluated
 265 by Perl for True or False, so the following are eqivalent:
 266
 267   $is_nullable = $field->is_nullable(0);
 268   $is_nullable = $field->is_nullable('');
 269   $is_nullable = $field->is_nullable('0');
 270
 271 While this is technically a field constraint, it's probably easier to
 272 represent this as an attribute of the field.  In order keep things
 273 consistent, any other constraint on the field (unique, primary, and
 274 foreign keys; checks) are represented as table constraints.
 275
 276 =cut
 277
 278 has is_nullable => (
 279     is => 'rw',
 280     coerce => sub { $_[0] ? 1 : 0 },
 281     default => sub { 1 },
 282  );
 283
 284 around is_nullable => sub {
 285     my ($orig, $self, $arg) = @_;
 286
 287     $self->$orig($self->is_primary_key ? 0 : defined $arg ? $arg : ());
 288 };
 289
 290 =head2 is_primary_key
 291
 292 Get or set the field's C<is_primary_key> attribute.  Does not create
 293 a table constraint (should it?).
 294
 295   my $is_pk = $field->is_primary_key(1);
 296
 297 =cut
 298
 299 has is_primary_key => (
 300     is => 'rw',
 301     coerce => sub { $_[0] ? 1 : 0 },
 302     lazy => 1,
 303     builder => 1,
 304 );
 305
 306 sub _build_is_primary_key {
 307     my ( $self ) = @_;
 308
 309     if ( my $table = $self->table ) {
 310         if ( my $pk = $table->primary_key ) {
 311             my %fields = map { $_, 1 } $pk->fields;
 312             return $fields{ $self->name } || 0;
 313         }
 314     }
 315     return 0;
 316 }
 317
 318 =head2 is_unique
 319
 320 Determine whether the field has a UNIQUE constraint or not.
 321
 322   my $is_unique = $field->is_unique;
 323
 324 =cut
 325
 326 has is_unique => ( is => 'lazy', init_arg => undef );
 327
 328 sub _build_is_unique {
 329     my ( $self ) = @_;
 330
 331     if ( my $table = $self->table ) {
 332         for my $c ( $table->get_constraints ) {
 333             if ( $c->type eq UNIQUE ) {
 334                 my %fields = map { $_, 1 } $c->fields;
 335                 if ( $fields{ $self->name } ) {
 336                     return 1;
 337                 }
 338             }
 339         }
 340     }
 341     return 0;
 342 }
 343
 344 sub is_valid {
 345
 346 =pod
 347
 348 =head2 is_valid
 349
 350 Determine whether the field is valid or not.
 351
 352   my $ok = $field->is_valid;
 353
 354 =cut
 355
 356     my $self = shift;
 357     return $self->error('No name')         unless $self->name;
 358     return $self->error('No data type')    unless $self->data_type;
 359     return $self->error('No table object') unless $self->table;
 360     return 1;
 361 }
 362
 363 =head2 name
 364
 365 Get or set the field's name.
 366
 367  my $name = $field->name('foo');
 368
 369 The field object will also stringify to its name.
 370
 371  my $setter_name = "set_$field";
 372
 373 Errors ("No field name") if you try to set a blank name.
 374
 375 =cut
 376
 377 has name => ( is => 'rw', isa => sub { throw( "No field name" ) unless $_[0] } );
 378
 379 around name => sub {
 380     my $orig = shift;
 381     my $self = shift;
 382
 383     if ( my ($arg) = @_ ) {
 384         if ( my $schema = $self->table ) {
 385             return $self->error( qq[Can't use field name "$arg": field exists] )
 386                 if $schema->get_field( $arg );
 387         }
 388     }
 389
 390     return ex2err($orig, $self, @_);
 391 };
 392
 393 sub full_name {
 394
 395 =head2 full_name
 396
 397 Read only method to return the fields name with its table name pre-pended.
 398 e.g. "person.foo".
 399
 400 =cut
 401
 402     my $self = shift;
 403     return $self->table.".".$self->name;
 404 }
 405
 406 =head2 order
 407
 408 Get or set the field's order.
 409
 410   my $order = $field->order(3);
 411
 412 =cut
 413
 414 has order => ( is => 'rw', default => sub { 0 } );
 415
 416 around order => sub {
 417     my ( $orig, $self, $arg ) = @_;
 418
 419     if ( defined $arg && $arg =~ /^\d+$/ ) {
 420         return $self->$orig($arg);
 421     }
 422
 423     return $self->$orig;
 424 };
 425
 426 sub schema {
 427
 428 =head2 schema
 429
 430 Shortcut to get the fields schema ($field->table->schema) or undef if it
 431 doesn't have one.
 432
 433   my $schema = $field->schema;
 434
 435 =cut
 436
 437     my $self = shift;
 438     if ( my $table = $self->table ) { return $table->schema || undef; }
 439     return undef;
 440 }
 441
 442 =head2 size
 443
 444 Get or set the field's size.  Accepts a string, array or arrayref of
 445 numbers and returns a string.
 446
 447   $field->size( 30 );
 448   $field->size( [ 255 ] );
 449   $size = $field->size( 10, 2 );
 450   print $size; # prints "10,2"
 451
 452   $size = $field->size( '10, 2' );
 453   print $size; # prints "10,2"
 454
 455 =cut
 456
 457 has size => (
 458     is => 'rw',
 459     default => sub { [0] },
 460     coerce => sub {
 461         my @sizes = grep { defined && m/^\d+(?:\.\d+)?$/ } @{parse_list_arg($_[0])};
 462         @sizes ? \@sizes : [0];
 463     },
 464 );
 465
 466 around size => sub {
 467     my $orig    = shift;
 468     my $self    = shift;
 469     my $numbers = parse_list_arg( @_ );
 470
 471     if ( @$numbers ) {
 472         my @new;
 473         for my $num ( @$numbers ) {
 474             if ( defined $num && $num =~ m/^\d+(?:\.\d+)?$/ ) {
 475                 push @new, $num;
 476             }
 477         }
 478         $self->$orig(\@new) if @new; # only set if all OK
 479     }
 480
 481     return wantarray
 482         ? @{ $self->$orig || [0] }
 483         : join( ',', @{ $self->$orig || [0] } )
 484     ;
 485 };
 486
 487 =head2 table
 488
 489 Get or set the field's table object. As the table object stringifies this can
 490 also be used to get the table name.
 491
 492   my $table = $field->table;
 493   print "Table name: $table";
 494
 495 =cut
 496
 497 has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
 498
 499 around table => \&ex2err;
 500
 501 =head2
 502
 503 Returns the field exactly as the parser found it
 504
 505 =cut
 506
 507 has parsed_field => ( is => 'rw' );
 508
 509 around parsed_field => sub {
 510     my $orig = shift;
 511     my $self = shift;
 512
 513     return $self->$orig(@_) || $self;
 514 };
 515
 516 =head2 equals
 517
 518 Determines if this field is the same as another
 519
 520   my $isIdentical = $field1->equals( $field2 );
 521
 522 =cut
 523
 524 around equals => sub {
 525     my $orig = shift;
 526     my $self = shift;
 527     my $other = shift;
 528     my $case_insensitive = shift;
 529
 530     return 0 unless $self->$orig($other);
 531     return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
 532
 533     # Comparing types: use sql_data_type if both are not 0. Else use string data_type
 534     if ($self->sql_data_type && $other->sql_data_type) {
 535         return 0 unless $self->sql_data_type == $other->sql_data_type
 536     } else {
 537         return 0 unless lc($self->data_type) eq lc($other->data_type)
 538     }
 539
 540     return 0 unless $self->size eq $other->size;
 541
 542     {
 543         my $lhs = $self->default_value;
 544            $lhs = \'NULL' unless defined $lhs;
 545         my $lhs_is_ref = ! ! ref $lhs;
 546
 547         my $rhs = $other->default_value;
 548            $rhs = \'NULL' unless defined $rhs;
 549         my $rhs_is_ref = ! ! ref $rhs;
 550
 551         # If only one is a ref, fail. -- rjbs, 2008-12-02
 552         return 0 if $lhs_is_ref xor $rhs_is_ref;
 553
 554         my $effective_lhs = $lhs_is_ref ? $$lhs : $lhs;
 555         my $effective_rhs = $rhs_is_ref ? $$rhs : $rhs;
 556
 557         return 0 if $effective_lhs ne $effective_rhs;
 558     }
 559
 560     return 0 unless $self->is_nullable eq $other->is_nullable;
 561 #    return 0 unless $self->is_unique eq $other->is_unique;
 562     return 0 unless $self->is_primary_key eq $other->is_primary_key;
 563 #    return 0 unless $self->is_foreign_key eq $other->is_foreign_key;
 564     return 0 unless $self->is_auto_increment eq $other->is_auto_increment;
 565 #    return 0 unless $self->comments eq $other->comments;
 566     return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
 567     return 1;
 568 };
 569
 570 # Must come after all 'has' declarations
 571 around new => \&ex2err;
 572
 573 1;
 574
 575 =pod
 576
 577 =head1 AUTHOR
 578
 579 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 580
 581 =cut