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