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