Clean up option parsing and identifier quoting in Producer::PostgreSQL
[dbsrgits/SQL-Translator.git] / 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 use Scalar::Util ();
31
32 extends 'SQL::Translator::Schema::Object';
33
34 our $VERSION = '1.59';
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!).
39 use overload
40     '""'     => sub { shift->name },
41     'bool'   => sub { $_[0]->name || $_[0] },
42     fallback => 1,
43 ;
44
45 use DBI qw(:sql_types);
46
47 # Mapping from string to sql constant
48 our %type_mapping = (
49   integer => SQL_INTEGER,
50   int     => SQL_INTEGER,
51
52   tinyint => SQL_TINYINT,
53   smallint => SQL_SMALLINT,
54   bigint => SQL_BIGINT,
55
56   double => SQL_DOUBLE,
57   'double precision' => SQL_DOUBLE,
58
59   decimal => SQL_DECIMAL,
60   dec => SQL_DECIMAL,
61   numeric => SQL_NUMERIC,
62
63   real => SQL_REAL,
64   float => SQL_FLOAT,
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 );
82
83 has _numeric_sql_data_types => ( is => 'lazy' );
84
85 sub _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
93 =head2 new
94
95 Object constructor.
96
97   my $field = SQL::Translator::Schema::Field->new(
98       name  => 'foo',
99       table => $table,
100   );
101
102 =head2 comments
103
104 Get or set the comments on a field.  May be called several times to
105 set and it will accumulate the comments.  Called in an array context,
106 returns each comment individually; called in a scalar context, returns
107 all 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
115 has comments => (
116     is => 'rw',
117     coerce => quote_sub(q{ ref($_[0]) eq 'ARRAY' ? $_[0] : [$_[0]] }),
118     default => quote_sub(q{ [] }),
119 );
120
121 around comments => sub {
122     my $orig = shift;
123     my $self = shift;
124
125     for my $arg ( @_ ) {
126         $arg = $arg->[0] if ref $arg;
127         push @{ $self->$orig }, $arg if $arg;
128     }
129
130     return wantarray
131         ? @{ $self->$orig }
132         : join( "\n", @{ $self->$orig } );
133 };
134
135
136 =head2 data_type
137
138 Get or set the field's data type.
139
140   my $data_type = $field->data_type('integer');
141
142 =cut
143
144 has data_type => ( is => 'rw', default => quote_sub(q{ '' }) );
145
146 =head2 sql_data_type
147
148 Constant from DBI package representing this data type. See L<DBI/DBI Constants>
149 for more details.
150
151 =cut
152
153 has sql_data_type => ( is => 'rw', lazy => 1, builder => 1 );
154
155 sub _build_sql_data_type {
156     $type_mapping{lc $_[0]->data_type} || SQL_UNKNOWN_TYPE;
157 }
158
159 =head2 default_value
160
161 Get or set the field's default value.  Will return undef if not defined
162 and could return the empty string (it's a valid default value), so don't
163 assume an error like other methods.
164
165   my $default = $field->default_value('foo');
166
167 =cut
168
169 has default_value => ( is => 'rw' );
170
171 =head2 foreign_key_reference
172
173 Get or set the field's foreign key reference;
174
175   my $constraint = $field->foreign_key_reference( $constraint );
176
177 =cut
178
179 has foreign_key_reference => (
180     is => 'rw',
181     predicate => '_has_foreign_key_reference',
182     isa => schema_obj('Constraint'),
183     weak_ref => 1,
184 );
185
186 around foreign_key_reference => sub {
187     my $orig = shift;
188     my $self = shift;
189
190     if ( my $arg = shift ) {
191         return $self->error(
192             'Foreign key reference for ', $self->name, 'already defined'
193         ) if $self->_has_foreign_key_reference;
194
195         return ex2err($orig, $self, $arg);
196     }
197     $self->$orig;
198 };
199
200 =head2 is_auto_increment
201
202 Get or set the field's C<is_auto_increment> attribute.
203
204   my $is_auto = $field->is_auto_increment(1);
205
206 =cut
207
208 has is_auto_increment => (
209     is => 'rw',
210     coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
211     builder => 1,
212     lazy => 1,
213 );
214
215 sub _build_is_auto_increment {
216     my ( $self ) = @_;
217
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;
225             }
226         }
227     }
228     return 0;
229 }
230
231 =head2 is_foreign_key
232
233 Returns whether or not the field is a foreign key.
234
235   my $is_fk = $field->is_foreign_key;
236
237 =cut
238
239 has is_foreign_key => (
240     is => 'rw',
241     coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
242     builder => 1,
243     lazy => 1,
244 );
245
246 sub _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;
256                 }
257             }
258         }
259     }
260     return 0;
261 }
262
263 =head2 is_nullable
264
265 Get or set whether the field can be null.  If not defined, then
266 returns "1" (assumes the field can be null).  The argument is evaluated
267 by Perl for True or False, so the following are equivalent:
268
269   $is_nullable = $field->is_nullable(0);
270   $is_nullable = $field->is_nullable('');
271   $is_nullable = $field->is_nullable('0');
272
273 While this is technically a field constraint, it's probably easier to
274 represent this as an attribute of the field.  In order keep things
275 consistent, any other constraint on the field (unique, primary, and
276 foreign keys; checks) are represented as table constraints.
277
278 =cut
279
280 has is_nullable => (
281     is => 'rw',
282     coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
283     default => quote_sub(q{ 1 }),
284  );
285
286 around is_nullable => sub {
287     my ($orig, $self, $arg) = @_;
288
289     $self->$orig($self->is_primary_key ? 0 : defined $arg ? $arg : ());
290 };
291
292 =head2 is_primary_key
293
294 Get or set the field's C<is_primary_key> attribute.  Does not create
295 a table constraint (should it?).
296
297   my $is_pk = $field->is_primary_key(1);
298
299 =cut
300
301 has is_primary_key => (
302     is => 'rw',
303     coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
304     lazy => 1,
305     builder => 1,
306 );
307
308 sub _build_is_primary_key {
309     my ( $self ) = @_;
310
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;
315         }
316     }
317     return 0;
318 }
319
320 =head2 is_unique
321
322 Determine whether the field has a UNIQUE constraint or not.
323
324   my $is_unique = $field->is_unique;
325
326 =cut
327
328 has is_unique => ( is => 'lazy', init_arg => undef );
329
330 around is_unique => carp_ro('is_unique');
331
332 sub _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;
341                 }
342             }
343         }
344     }
345     return 0;
346 }
347
348 sub is_valid {
349
350 =pod
351
352 =head2 is_valid
353
354 Determine 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
367 =head2 name
368
369 Get or set the field's name.
370
371  my $name = $field->name('foo');
372
373 The field object will also stringify to its name.
374
375  my $setter_name = "set_$field";
376
377 Errors ("No field name") if you try to set a blank name.
378
379 =cut
380
381 has name => ( is => 'rw', isa => sub { throw( "No field name" ) unless $_[0] } );
382
383 around name => sub {
384     my $orig = shift;
385     my $self = shift;
386
387     if ( my ($arg) = @_ ) {
388         if ( my $schema = $self->table ) {
389             return $self->error( qq[Can't use field name "$arg": field exists] )
390                 if $schema->get_field( $arg );
391         }
392     }
393
394     return ex2err($orig, $self, @_);
395 };
396
397 sub full_name {
398
399 =head2 full_name
400
401 Read only method to return the fields name with its table name pre-pended.
402 e.g. "person.foo".
403
404 =cut
405
406     my $self = shift;
407     return $self->table.".".$self->name;
408 }
409
410 =head2 order
411
412 Get or set the field's order.
413
414   my $order = $field->order(3);
415
416 =cut
417
418 has order => ( is => 'rw', default => quote_sub(q{ 0 }) );
419
420 around order => sub {
421     my ( $orig, $self, $arg ) = @_;
422
423     if ( defined $arg && $arg =~ /^\d+$/ ) {
424         return $self->$orig($arg);
425     }
426
427     return $self->$orig;
428 };
429
430 sub schema {
431
432 =head2 schema
433
434 Shortcut to get the fields schema ($field->table->schema) or undef if it
435 doesn'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
446 =head2 size
447
448 Get or set the field's size.  Accepts a string, array or arrayref of
449 numbers 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
461 has size => (
462     is => 'rw',
463     default => quote_sub(q{ [0] }),
464     coerce => sub {
465         my @sizes = grep { defined && m/^\d+(?:\.\d+)?$/ } @{parse_list_arg($_[0])};
466         @sizes ? \@sizes : [0];
467     },
468 );
469
470 around size => sub {
471     my $orig    = shift;
472     my $self    = shift;
473     my $numbers = parse_list_arg( @_ );
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         }
482         $self->$orig(\@new) if @new; # only set if all OK
483     }
484
485     return wantarray
486         ? @{ $self->$orig || [0] }
487         : join( ',', @{ $self->$orig || [0] } )
488     ;
489 };
490
491 =head2 table
492
493 Get or set the field's table object. As the table object stringifies this can
494 also be used to get the table name.
495
496   my $table = $field->table;
497   print "Table name: $table";
498
499 =cut
500
501 has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
502
503 around table => \&ex2err;
504
505 =head2 parsed_field
506
507 Returns the field exactly as the parser found it
508
509 =cut
510
511 has parsed_field => ( is => 'rw' );
512
513 around parsed_field => sub {
514     my $orig = shift;
515     my $self = shift;
516
517     return $self->$orig(@_) || $self;
518 };
519
520 =head2 equals
521
522 Determines if this field is the same as another
523
524   my $isIdentical = $field1->equals( $field2 );
525
526 =cut
527
528 around equals => sub {
529     my $orig = shift;
530     my $self = shift;
531     my $other = shift;
532     my $case_insensitive = shift;
533
534     return 0 unless $self->$orig($other);
535     return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
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
544     return 0 unless $self->size eq $other->size;
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
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         }
569     }
570
571     return 0 unless $self->is_nullable eq $other->is_nullable;
572 #    return 0 unless $self->is_unique eq $other->is_unique;
573     return 0 unless $self->is_primary_key eq $other->is_primary_key;
574 #    return 0 unless $self->is_foreign_key eq $other->is_foreign_key;
575     return 0 unless $self->is_auto_increment eq $other->is_auto_increment;
576 #    return 0 unless $self->comments eq $other->comments;
577     return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
578     return 1;
579 };
580
581 # Must come after all 'has' declarations
582 around new => \&ex2err;
583
584 sub _is_numeric_data_type {
585     my $self = shift;
586     return $self->_numeric_sql_data_types->{ $self->sql_data_type };
587 }
588
589 1;
590
591 =pod
592
593 =head1 AUTHOR
594
595 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
596
597 =cut