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