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