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