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