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 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 => 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 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 => quote_sub(q{ $_[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 => quote_sub(q{ $_[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 => quote_sub(q{ $_[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 => quote_sub(q{ $_[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 around is_unique => carp_ro('is_unique');
 325
 326 sub _build_is_unique {
 327     my ( $self ) = @_;
 328
 329     if ( my $table = $self->table ) {
 330         for my $c ( $table->get_constraints ) {
 331             if ( $c->type eq UNIQUE ) {
 332                 my %fields = map { $_, 1 } $c->fields;
 333                 if ( $fields{ $self->name } ) {
 334                     return 1;
 335                 }
 336             }
 337         }
 338     }
 339     return 0;
 340 }
 341
 342 sub is_valid {
 343
 344 =pod
 345
 346 =head2 is_valid
 347
 348 Determine whether the field is valid or not.
 349
 350   my $ok = $field->is_valid;
 351
 352 =cut
 353
 354     my $self = shift;
 355     return $self->error('No name')         unless $self->name;
 356     return $self->error('No data type')    unless $self->data_type;
 357     return $self->error('No table object') unless $self->table;
 358     return 1;
 359 }
 360
 361 =head2 name
 362
 363 Get or set the field's name.
 364
 365  my $name = $field->name('foo');
 366
 367 The field object will also stringify to its name.
 368
 369  my $setter_name = "set_$field";
 370
 371 Errors ("No field name") if you try to set a blank name.
 372
 373 =cut
 374
 375 has name => ( is => 'rw', isa => sub { throw( "No field name" ) unless $_[0] } );
 376
 377 around name => sub {
 378     my $orig = shift;
 379     my $self = shift;
 380
 381     if ( my ($arg) = @_ ) {
 382         if ( my $schema = $self->table ) {
 383             return $self->error( qq[Can't use field name "$arg": field exists] )
 384                 if $schema->get_field( $arg );
 385         }
 386     }
 387
 388     return ex2err($orig, $self, @_);
 389 };
 390
 391 sub full_name {
 392
 393 =head2 full_name
 394
 395 Read only method to return the fields name with its table name pre-pended.
 396 e.g. "person.foo".
 397
 398 =cut
 399
 400     my $self = shift;
 401     return $self->table.".".$self->name;
 402 }
 403
 404 =head2 order
 405
 406 Get or set the field's order.
 407
 408   my $order = $field->order(3);
 409
 410 =cut
 411
 412 has order => ( is => 'rw', default => quote_sub(q{ 0 }) );
 413
 414 around order => sub {
 415     my ( $orig, $self, $arg ) = @_;
 416
 417     if ( defined $arg && $arg =~ /^\d+$/ ) {
 418         return $self->$orig($arg);
 419     }
 420
 421     return $self->$orig;
 422 };
 423
 424 sub schema {
 425
 426 =head2 schema
 427
 428 Shortcut to get the fields schema ($field->table->schema) or undef if it
 429 doesn't have one.
 430
 431   my $schema = $field->schema;
 432
 433 =cut
 434
 435     my $self = shift;
 436     if ( my $table = $self->table ) { return $table->schema || undef; }
 437     return undef;
 438 }
 439
 440 =head2 size
 441
 442 Get or set the field's size.  Accepts a string, array or arrayref of
 443 numbers and returns a string.
 444
 445   $field->size( 30 );
 446   $field->size( [ 255 ] );
 447   $size = $field->size( 10, 2 );
 448   print $size; # prints "10,2"
 449
 450   $size = $field->size( '10, 2' );
 451   print $size; # prints "10,2"
 452
 453 =cut
 454
 455 has size => (
 456     is => 'rw',
 457     default => quote_sub(q{ [0] }),
 458     coerce => sub {
 459         my @sizes = grep { defined && m/^\d+(?:\.\d+)?$/ } @{parse_list_arg($_[0])};
 460         @sizes ? \@sizes : [0];
 461     },
 462 );
 463
 464 around size => sub {
 465     my $orig    = shift;
 466     my $self    = shift;
 467     my $numbers = parse_list_arg( @_ );
 468
 469     if ( @$numbers ) {
 470         my @new;
 471         for my $num ( @$numbers ) {
 472             if ( defined $num && $num =~ m/^\d+(?:\.\d+)?$/ ) {
 473                 push @new, $num;
 474             }
 475         }
 476         $self->$orig(\@new) if @new; # only set if all OK
 477     }
 478
 479     return wantarray
 480         ? @{ $self->$orig || [0] }
 481         : join( ',', @{ $self->$orig || [0] } )
 482     ;
 483 };
 484
 485 =head2 table
 486
 487 Get or set the field's table object. As the table object stringifies this can
 488 also be used to get the table name.
 489
 490   my $table = $field->table;
 491   print "Table name: $table";
 492
 493 =cut
 494
 495 has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
 496
 497 around table => \&ex2err;
 498
 499 =head2
 500
 501 Returns the field exactly as the parser found it
 502
 503 =cut
 504
 505 has parsed_field => ( is => 'rw' );
 506
 507 around parsed_field => sub {
 508     my $orig = shift;
 509     my $self = shift;
 510
 511     return $self->$orig(@_) || $self;
 512 };
 513
 514 =head2 equals
 515
 516 Determines if this field is the same as another
 517
 518   my $isIdentical = $field1->equals( $field2 );
 519
 520 =cut
 521
 522 around equals => sub {
 523     my $orig = shift;
 524     my $self = shift;
 525     my $other = shift;
 526     my $case_insensitive = shift;
 527
 528     return 0 unless $self->$orig($other);
 529     return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
 530
 531     # Comparing types: use sql_data_type if both are not 0. Else use string data_type
 532     if ($self->sql_data_type && $other->sql_data_type) {
 533         return 0 unless $self->sql_data_type == $other->sql_data_type
 534     } else {
 535         return 0 unless lc($self->data_type) eq lc($other->data_type)
 536     }
 537
 538     return 0 unless $self->size eq $other->size;
 539
 540     {
 541         my $lhs = $self->default_value;
 542            $lhs = \'NULL' unless defined $lhs;
 543         my $lhs_is_ref = ! ! ref $lhs;
 544
 545         my $rhs = $other->default_value;
 546            $rhs = \'NULL' unless defined $rhs;
 547         my $rhs_is_ref = ! ! ref $rhs;
 548
 549         # If only one is a ref, fail. -- rjbs, 2008-12-02
 550         return 0 if $lhs_is_ref xor $rhs_is_ref;
 551
 552         my $effective_lhs = $lhs_is_ref ? $$lhs : $lhs;
 553         my $effective_rhs = $rhs_is_ref ? $$rhs : $rhs;
 554
 555         return 0 if $effective_lhs ne $effective_rhs;
 556     }
 557
 558     return 0 unless $self->is_nullable eq $other->is_nullable;
 559 #    return 0 unless $self->is_unique eq $other->is_unique;
 560     return 0 unless $self->is_primary_key eq $other->is_primary_key;
 561 #    return 0 unless $self->is_foreign_key eq $other->is_foreign_key;
 562     return 0 unless $self->is_auto_increment eq $other->is_auto_increment;
 563 #    return 0 unless $self->comments eq $other->comments;
 564     return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
 565     return 1;
 566 };
 567
 568 # Must come after all 'has' declarations
 569 around new => \&ex2err;
 570
 571 1;
 572
 573 =pod
 574
 575 =head1 AUTHOR
 576
 577 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 578
 579 =cut