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.59';
  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
  58   decimal => SQL_DECIMAL,
  59   numeric => SQL_NUMERIC,
  60   dec => SQL_DECIMAL,
  61
  62   bit => SQL_BIT,
  63
  64   date => SQL_DATE,
  65   datetime => SQL_DATETIME,
  66   timestamp => SQL_TIMESTAMP,
  67   time => SQL_TIME,
  68
  69   char => SQL_CHAR,
  70   varchar => SQL_VARCHAR,
  71   binary => SQL_BINARY,
  72   varbinary => SQL_VARBINARY,
  73   tinyblob => SQL_BLOB,
  74   blob => SQL_BLOB,
  75   text => SQL_LONGVARCHAR
  76
  77 );
  78
  79 has _numeric_sql_data_types => ( is => 'lazy' );
  80
  81 sub _build__numeric_sql_data_types {
  82     return {
  83         map { $_ => 1 }
  84             (SQL_INTEGER, SQL_TINYINT, SQL_SMALLINT, SQL_BIGINT, SQL_DOUBLE,
  85              SQL_NUMERIC, SQL_DECIMAL, SQL_FLOAT, SQL_REAL)
  86     };
  87 }
  88
  89 =head2 new
  90
  91 Object constructor.
  92
  93   my $field = SQL::Translator::Schema::Field->new(
  94       name  => 'foo',
  95       table => $table,
  96   );
  97
  98 =head2 comments
  99
 100 Get or set the comments on a field.  May be called several times to
 101 set and it will accumulate the comments.  Called in an array context,
 102 returns each comment individually; called in a scalar context, returns
 103 all the comments joined on newlines.
 104
 105   $field->comments('foo');
 106   $field->comments('bar');
 107   print join( ', ', $field->comments ); # prints "foo, bar"
 108
 109 =cut
 110
 111 has comments => (
 112     is => 'rw',
 113     coerce => quote_sub(q{ ref($_[0]) eq 'ARRAY' ? $_[0] : [$_[0]] }),
 114     default => quote_sub(q{ [] }),
 115 );
 116
 117 around comments => sub {
 118     my $orig = shift;
 119     my $self = shift;
 120
 121     for my $arg ( @_ ) {
 122         $arg = $arg->[0] if ref $arg;
 123         push @{ $self->$orig }, $arg if $arg;
 124     }
 125
 126     return wantarray
 127         ? @{ $self->$orig }
 128         : join( "\n", @{ $self->$orig } );
 129 };
 130
 131
 132 =head2 data_type
 133
 134 Get or set the field's data type.
 135
 136   my $data_type = $field->data_type('integer');
 137
 138 =cut
 139
 140 has data_type => ( is => 'rw', default => quote_sub(q{ '' }) );
 141
 142 =head2 sql_data_type
 143
 144 Constant from DBI package representing this data type. See L<DBI/DBI Constants>
 145 for more details.
 146
 147 =cut
 148
 149 has sql_data_type => ( is => 'rw', lazy => 1, builder => 1 );
 150
 151 sub _build_sql_data_type {
 152     $type_mapping{lc $_[0]->data_type} || SQL_UNKNOWN_TYPE;
 153 }
 154
 155 =head2 default_value
 156
 157 Get or set the field's default value.  Will return undef if not defined
 158 and could return the empty string (it's a valid default value), so don't
 159 assume an error like other methods.
 160
 161   my $default = $field->default_value('foo');
 162
 163 =cut
 164
 165 has default_value => ( is => 'rw' );
 166
 167 =head2 foreign_key_reference
 168
 169 Get or set the field's foreign key reference;
 170
 171   my $constraint = $field->foreign_key_reference( $constraint );
 172
 173 =cut
 174
 175 has foreign_key_reference => (
 176     is => 'rw',
 177     predicate => '_has_foreign_key_reference',
 178     isa => schema_obj('Constraint'),
 179     weak_ref => 1,
 180 );
 181
 182 around foreign_key_reference => sub {
 183     my $orig = shift;
 184     my $self = shift;
 185
 186     if ( my $arg = shift ) {
 187         return $self->error(
 188             'Foreign key reference for ', $self->name, 'already defined'
 189         ) if $self->_has_foreign_key_reference;
 190
 191         return ex2err($orig, $self, $arg);
 192     }
 193     $self->$orig;
 194 };
 195
 196 =head2 is_auto_increment
 197
 198 Get or set the field's C<is_auto_increment> attribute.
 199
 200   my $is_auto = $field->is_auto_increment(1);
 201
 202 =cut
 203
 204 has is_auto_increment => (
 205     is => 'rw',
 206     coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
 207     builder => 1,
 208     lazy => 1,
 209 );
 210
 211 sub _build_is_auto_increment {
 212     my ( $self ) = @_;
 213
 214     if ( my $table = $self->table ) {
 215         if ( my $schema = $table->schema ) {
 216             if (
 217                 $schema->database eq 'PostgreSQL' &&
 218                 $self->data_type eq 'serial'
 219             ) {
 220                 return 1;
 221             }
 222         }
 223     }
 224     return 0;
 225 }
 226
 227 =head2 is_foreign_key
 228
 229 Returns whether or not the field is a foreign key.
 230
 231   my $is_fk = $field->is_foreign_key;
 232
 233 =cut
 234
 235 has is_foreign_key => (
 236     is => 'rw',
 237     coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
 238     builder => 1,
 239     lazy => 1,
 240 );
 241
 242 sub _build_is_foreign_key {
 243     my ( $self ) = @_;
 244
 245     if ( my $table = $self->table ) {
 246         for my $c ( $table->get_constraints ) {
 247             if ( $c->type eq FOREIGN_KEY ) {
 248                 my %fields = map { $_, 1 } $c->fields;
 249                 if ( $fields{ $self->name } ) {
 250                     $self->foreign_key_reference( $c );
 251                     return 1;
 252                 }
 253             }
 254         }
 255     }
 256     return 0;
 257 }
 258
 259 =head2 is_nullable
 260
 261 Get or set whether the field can be null.  If not defined, then
 262 returns "1" (assumes the field can be null).  The argument is evaluated
 263 by Perl for True or False, so the following are equivalent:
 264
 265   $is_nullable = $field->is_nullable(0);
 266   $is_nullable = $field->is_nullable('');
 267   $is_nullable = $field->is_nullable('0');
 268
 269 While this is technically a field constraint, it's probably easier to
 270 represent this as an attribute of the field.  In order keep things
 271 consistent, any other constraint on the field (unique, primary, and
 272 foreign keys; checks) are represented as table constraints.
 273
 274 =cut
 275
 276 has is_nullable => (
 277     is => 'rw',
 278     coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
 279     default => quote_sub(q{ 1 }),
 280  );
 281
 282 around is_nullable => sub {
 283     my ($orig, $self, $arg) = @_;
 284
 285     $self->$orig($self->is_primary_key ? 0 : defined $arg ? $arg : ());
 286 };
 287
 288 =head2 is_primary_key
 289
 290 Get or set the field's C<is_primary_key> attribute.  Does not create
 291 a table constraint (should it?).
 292
 293   my $is_pk = $field->is_primary_key(1);
 294
 295 =cut
 296
 297 has is_primary_key => (
 298     is => 'rw',
 299     coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
 300     lazy => 1,
 301     builder => 1,
 302 );
 303
 304 sub _build_is_primary_key {
 305     my ( $self ) = @_;
 306
 307     if ( my $table = $self->table ) {
 308         if ( my $pk = $table->primary_key ) {
 309             my %fields = map { $_, 1 } $pk->fields;
 310             return $fields{ $self->name } || 0;
 311         }
 312     }
 313     return 0;
 314 }
 315
 316 =head2 is_unique
 317
 318 Determine whether the field has a UNIQUE constraint or not.
 319
 320   my $is_unique = $field->is_unique;
 321
 322 =cut
 323
 324 has is_unique => ( is => 'lazy', init_arg => undef );
 325
 326 around is_unique => carp_ro('is_unique');
 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 => quote_sub(q{ 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 => quote_sub(q{ [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 parsed_field
 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         if ( $self->_is_numeric_data_type
 558              && Scalar::Util::looks_like_number($effective_lhs)
 559              && Scalar::Util::looks_like_number($effective_rhs) ) {
 560             return 0 if ($effective_lhs + 0) != ($effective_rhs + 0);
 561         }
 562         else {
 563             return 0 if $effective_lhs ne $effective_rhs;
 564         }
 565     }
 566
 567     return 0 unless $self->is_nullable eq $other->is_nullable;
 568 #    return 0 unless $self->is_unique eq $other->is_unique;
 569     return 0 unless $self->is_primary_key eq $other->is_primary_key;
 570 #    return 0 unless $self->is_foreign_key eq $other->is_foreign_key;
 571     return 0 unless $self->is_auto_increment eq $other->is_auto_increment;
 572 #    return 0 unless $self->comments eq $other->comments;
 573     return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
 574     return 1;
 575 };
 576
 577 # Must come after all 'has' declarations
 578 around new => \&ex2err;
 579
 580 sub _is_numeric_data_type {
 581     my $self = shift;
 582     return $self->_numeric_sql_data_types->{ $self->sql_data_type };
 583 }
 584
 585 1;
 586
 587 =pod
 588
 589 =head1 AUTHOR
 590
 591 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 592
 593 =cut