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 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 contstant
  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 constatn 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 => sub { 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 extra
 156
 157 Get or set the field's "extra" attibutes (e.g., "ZEROFILL" for MySQL).
 158 Accepts a hash(ref) of name/value pairs to store;  returns a hash.
 159
 160   $field->extra( qualifier => 'ZEROFILL' );
 161   my %extra = $field->extra;
 162
 163 =cut
 164
 165 =head2 foreign_key_reference
 166
 167 Get or set the field's foreign key reference;
 168
 169   my $constraint = $field->foreign_key_reference( $constraint );
 170
 171 =cut
 172
 173 has foreign_key_reference => (
 174     is => 'rw',
 175     predicate => '_has_foreign_key_reference',
 176     isa => schema_obj('Constraint'),
 177     weak_ref => 1,
 178 );
 179
 180 around foreign_key_reference => sub {
 181     my $orig = shift;
 182     my $self = shift;
 183
 184     if ( my $arg = shift ) {
 185         return $self->error(
 186             'Foreign key reference for ', $self->name, 'already defined'
 187         ) if $self->_has_foreign_key_reference;
 188
 189         return ex2err($orig, $self, $arg);
 190     }
 191     $self->$orig;
 192 };
 193
 194 =head2 is_auto_increment
 195
 196 Get or set the field's C<is_auto_increment> attribute.
 197
 198   my $is_auto = $field->is_auto_increment(1);
 199
 200 =cut
 201
 202 has is_auto_increment => (
 203     is => 'rw',
 204     coerce => sub { $_[0] ? 1 : 0 },
 205     builder => 1,
 206     lazy => 1,
 207 );
 208
 209 sub _build_is_auto_increment {
 210     my ( $self ) = @_;
 211
 212     if ( my $table = $self->table ) {
 213         if ( my $schema = $table->schema ) {
 214             if (
 215                 $schema->database eq 'PostgreSQL' &&
 216                 $self->data_type eq 'serial'
 217             ) {
 218                 return 1;
 219             }
 220         }
 221     }
 222     return 0;
 223 }
 224
 225 =head2 is_foreign_key
 226
 227 Returns whether or not the field is a foreign key.
 228
 229   my $is_fk = $field->is_foreign_key;
 230
 231 =cut
 232
 233 has is_foreign_key => (
 234     is => 'rw',
 235     coerce => sub { $_[0] ? 1 : 0 },
 236     builder => 1,
 237     lazy => 1,
 238 );
 239
 240 sub _build_is_foreign_key {
 241     my ( $self ) = @_;
 242
 243     if ( my $table = $self->table ) {
 244         for my $c ( $table->get_constraints ) {
 245             if ( $c->type eq FOREIGN_KEY ) {
 246                 my %fields = map { $_, 1 } $c->fields;
 247                 if ( $fields{ $self->name } ) {
 248                     $self->foreign_key_reference( $c );
 249                     return 1;
 250                 }
 251             }
 252         }
 253     }
 254     return 0;
 255 }
 256
 257 =head2 is_nullable
 258
 259 Get or set whether the field can be null.  If not defined, then
 260 returns "1" (assumes the field can be null).  The argument is evaluated
 261 by Perl for True or False, so the following are eqivalent:
 262
 263   $is_nullable = $field->is_nullable(0);
 264   $is_nullable = $field->is_nullable('');
 265   $is_nullable = $field->is_nullable('0');
 266
 267 While this is technically a field constraint, it's probably easier to
 268 represent this as an attribute of the field.  In order keep things
 269 consistent, any other constraint on the field (unique, primary, and
 270 foreign keys; checks) are represented as table constraints.
 271
 272 =cut
 273
 274 has is_nullable => (
 275     is => 'rw',
 276     coerce => sub { $_[0] ? 1 : 0 },
 277     default => quote_sub(q{ 1 }),
 278  );
 279
 280 around is_nullable => sub {
 281     my ($orig, $self, $arg) = @_;
 282
 283     $self->$orig($self->is_primary_key ? 0 : defined $arg ? $arg : ());
 284 };
 285
 286 =head2 is_primary_key
 287
 288 Get or set the field's C<is_primary_key> attribute.  Does not create
 289 a table constraint (should it?).
 290
 291   my $is_pk = $field->is_primary_key(1);
 292
 293 =cut
 294
 295 has is_primary_key => (
 296     is => 'rw',
 297     coerce => sub { $_[0] ? 1 : 0 },
 298     lazy => 1,
 299     builder => 1,
 300 );
 301
 302 sub _build_is_primary_key {
 303     my ( $self ) = @_;
 304
 305     if ( my $table = $self->table ) {
 306         if ( my $pk = $table->primary_key ) {
 307             my %fields = map { $_, 1 } $pk->fields;
 308             return $fields{ $self->name } || 0;
 309         }
 310     }
 311     return 0;
 312 }
 313
 314 =head2 is_unique
 315
 316 Determine whether the field has a UNIQUE constraint or not.
 317
 318   my $is_unique = $field->is_unique;
 319
 320 =cut
 321
 322 has is_unique => ( is => 'lazy', init_arg => undef );
 323
 324 sub _build_is_unique {
 325     my ( $self ) = @_;
 326
 327     if ( my $table = $self->table ) {
 328         for my $c ( $table->get_constraints ) {
 329             if ( $c->type eq UNIQUE ) {
 330                 my %fields = map { $_, 1 } $c->fields;
 331                 if ( $fields{ $self->name } ) {
 332                     return 1;
 333                 }
 334             }
 335         }
 336     }
 337     return 0;
 338 }
 339
 340 sub is_valid {
 341
 342 =pod
 343
 344 =head2 is_valid
 345
 346 Determine whether the field is valid or not.
 347
 348   my $ok = $field->is_valid;
 349
 350 =cut
 351
 352     my $self = shift;
 353     return $self->error('No name')         unless $self->name;
 354     return $self->error('No data type')    unless $self->data_type;
 355     return $self->error('No table object') unless $self->table;
 356     return 1;
 357 }
 358
 359 =head2 name
 360
 361 Get or set the field's name.
 362
 363  my $name = $field->name('foo');
 364
 365 The field object will also stringify to its name.
 366
 367  my $setter_name = "set_$field";
 368
 369 Errors ("No field name") if you try to set a blank name.
 370
 371 =cut
 372
 373 has name => ( is => 'rw', isa => sub { throw( "No field name" ) unless $_[0] } );
 374
 375 around name => sub {
 376     my $orig = shift;
 377     my $self = shift;
 378
 379     if ( my ($arg) = @_ ) {
 380         if ( my $schema = $self->table ) {
 381             return $self->error( qq[Can't use field name "$arg": field exists] )
 382                 if $schema->get_field( $arg );
 383         }
 384     }
 385
 386     return ex2err($orig, $self, @_);
 387 };
 388
 389 sub full_name {
 390
 391 =head2 full_name
 392
 393 Read only method to return the fields name with its table name pre-pended.
 394 e.g. "person.foo".
 395
 396 =cut
 397
 398     my $self = shift;
 399     return $self->table.".".$self->name;
 400 }
 401
 402 =head2 order
 403
 404 Get or set the field's order.
 405
 406   my $order = $field->order(3);
 407
 408 =cut
 409
 410 has order => ( is => 'rw', default => quote_sub(q{ 0 }) );
 411
 412 around order => sub {
 413     my ( $orig, $self, $arg ) = @_;
 414
 415     if ( defined $arg && $arg =~ /^\d+$/ ) {
 416         return $self->$orig($arg);
 417     }
 418
 419     return $self->$orig;
 420 };
 421
 422 sub schema {
 423
 424 =head2 schema
 425
 426 Shortcut to get the fields schema ($field->table->schema) or undef if it
 427 doesn't have one.
 428
 429   my $schema = $field->schema;
 430
 431 =cut
 432
 433     my $self = shift;
 434     if ( my $table = $self->table ) { return $table->schema || undef; }
 435     return undef;
 436 }
 437
 438 =head2 size
 439
 440 Get or set the field's size.  Accepts a string, array or arrayref of
 441 numbers and returns a string.
 442
 443   $field->size( 30 );
 444   $field->size( [ 255 ] );
 445   $size = $field->size( 10, 2 );
 446   print $size; # prints "10,2"
 447
 448   $size = $field->size( '10, 2' );
 449   print $size; # prints "10,2"
 450
 451 =cut
 452
 453 has size => (
 454     is => 'rw',
 455     default => quote_sub(q{ [0] }),
 456     coerce => sub {
 457         my @sizes = grep { defined && m/^\d+(?:\.\d+)?$/ } @{parse_list_arg($_[0])};
 458         @sizes ? \@sizes : [0];
 459     },
 460 );
 461
 462 around size => sub {
 463     my $orig    = shift;
 464     my $self    = shift;
 465     my $numbers = parse_list_arg( @_ );
 466
 467     if ( @$numbers ) {
 468         my @new;
 469         for my $num ( @$numbers ) {
 470             if ( defined $num && $num =~ m/^\d+(?:\.\d+)?$/ ) {
 471                 push @new, $num;
 472             }
 473         }
 474         $self->$orig(\@new) if @new; # only set if all OK
 475     }
 476
 477     return wantarray
 478         ? @{ $self->$orig || [0] }
 479         : join( ',', @{ $self->$orig || [0] } )
 480     ;
 481 };
 482
 483 =head2 table
 484
 485 Get or set the field's table object. As the table object stringifies this can
 486 also be used to get the table name.
 487
 488   my $table = $field->table;
 489   print "Table name: $table";
 490
 491 =cut
 492
 493 has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
 494
 495 around table => \&ex2err;
 496
 497 =head2
 498
 499 Returns the field exactly as the parser found it
 500
 501 =cut
 502
 503 has parsed_field => ( is => 'rw' );
 504
 505 around parsed_field => sub {
 506     my $orig = shift;
 507     my $self = shift;
 508
 509     return $self->$orig(@_) || $self;
 510 };
 511
 512 =head2 equals
 513
 514 Determines if this field is the same as another
 515
 516   my $isIdentical = $field1->equals( $field2 );
 517
 518 =cut
 519
 520 around equals => sub {
 521     my $orig = shift;
 522     my $self = shift;
 523     my $other = shift;
 524     my $case_insensitive = shift;
 525
 526     return 0 unless $self->$orig($other);
 527     return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
 528
 529     # Comparing types: use sql_data_type if both are not 0. Else use string data_type
 530     if ($self->sql_data_type && $other->sql_data_type) {
 531         return 0 unless $self->sql_data_type == $other->sql_data_type
 532     } else {
 533         return 0 unless lc($self->data_type) eq lc($other->data_type)
 534     }
 535
 536     return 0 unless $self->size eq $other->size;
 537
 538     {
 539         my $lhs = $self->default_value;
 540            $lhs = \'NULL' unless defined $lhs;
 541         my $lhs_is_ref = ! ! ref $lhs;
 542
 543         my $rhs = $other->default_value;
 544            $rhs = \'NULL' unless defined $rhs;
 545         my $rhs_is_ref = ! ! ref $rhs;
 546
 547         # If only one is a ref, fail. -- rjbs, 2008-12-02
 548         return 0 if $lhs_is_ref xor $rhs_is_ref;
 549
 550         my $effective_lhs = $lhs_is_ref ? $$lhs : $lhs;
 551         my $effective_rhs = $rhs_is_ref ? $$rhs : $rhs;
 552
 553         return 0 if $effective_lhs ne $effective_rhs;
 554     }
 555
 556     return 0 unless $self->is_nullable eq $other->is_nullable;
 557 #    return 0 unless $self->is_unique eq $other->is_unique;
 558     return 0 unless $self->is_primary_key eq $other->is_primary_key;
 559 #    return 0 unless $self->is_foreign_key eq $other->is_foreign_key;
 560     return 0 unless $self->is_auto_increment eq $other->is_auto_increment;
 561 #    return 0 unless $self->comments eq $other->comments;
 562     return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
 563     return 1;
 564 };
 565
 566 # Must come after all 'has' declarations
 567 around new => \&ex2err;
 568
 569 1;
 570
 571 =pod
 572
 573 =head1 AUTHOR
 574
 575 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 576
 577 =cut