File Coverage

blib/lib/SQL/Translator/Schema/Field.pm
Criterion Covered Total %
statement 73 74 98.6
branch 27 34 79.4
condition 4 7 57.1
subroutine 20 20 100.0
pod 3 3 100.0
total 127 138 92.0


line stmt bran cond sub pod time code
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 is the field object.
20              
21             =head1 METHODS
22              
23             =cut
24              
25 73     73   871 use Moo;
  73         153  
  73         445  
26 73     73   21219 use SQL::Translator::Schema::Constants;
  73         164  
  73         4988  
27 73     73   741 use SQL::Translator::Types qw(schema_obj);
  73         153  
  73         3011  
28 73     73   423 use SQL::Translator::Utils qw(parse_list_arg ex2err throw carp_ro);
  73         161  
  73         3737  
29 73     73   426 use Sub::Quote qw(quote_sub);
  73         186  
  73         2712  
30 73     73   448 use Scalar::Util ();
  73         152  
  73         6939  
31              
32             extends 'SQL::Translator::Schema::Object';
33              
34             our $VERSION = '1.6_3';
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 4148     4148   80476 '""' => sub { shift->name },
41 15912 50   15912   432126 'bool' => sub { $_[0]->name || $_[0] },
42 73         859 fallback => 1,
43 73     73   543 ;
  73         141  
44              
45 73     73   101172 use DBI qw(:sql_types);
  73         1048738  
  73         161481  
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 139     139   1919 map { $_ => 1 }
  1251         4509  
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
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 243 100   243   4357 $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 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 565     565   10454 my ( $self ) = @_;
217              
218 565 100       8799 if ( my $table = $self->table ) {
219 560 100       17512 if ( my $schema = $table->schema ) {
220 538 100 66     10615 if (
221             $schema->database eq 'PostgreSQL' &&
222             $self->data_type eq 'serial'
223             ) {
224 1         18 return 1;
225             }
226             }
227             }
228 564         9009 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 177     177   13023 my ( $self ) = @_;
248              
249 177 50       2796 if ( my $table = $self->table ) {
250 177         3021 for my $c ( $table->get_constraints ) {
251 371 100       9630 if ( $c->type eq FOREIGN_KEY ) {
252 93         1528 my %fields = map { $_, 1 } $c->fields;
  93         284  
253 93 100       2706 if ( $fields{ $self->name } ) {
254 14         465 $self->foreign_key_reference( $c );
255 14         532 return 1;
256             }
257             }
258             }
259             }
260 163         4641 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 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 562     562   8556 my ( $self ) = @_;
310              
311 562 100       8812 if ( my $table = $self->table ) {
312 560 100       10005 if ( my $pk = $table->primary_key ) {
313 431         9181 my %fields = map { $_, 1 } $pk->fields;
  454         1519  
314 431   50     13341 return $fields{ $self->name } || 0;
315             }
316             }
317 131         2023 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 91     91   726 my ( $self ) = @_;
334              
335 91 50       1351 if ( my $table = $self->table ) {
336 91         1590 for my $c ( $table->get_constraints ) {
337 203 100       5408 if ( $c->type eq UNIQUE ) {
338 77         1280 my %fields = map { $_, 1 } $c->fields;
  77         254  
339 77 100       2428 if ( $fields{ $self->name } ) {
340 10         284 return 1;
341             }
342             }
343             }
344             }
345 81         2118 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 320     320 1 788 my $self = shift;
361 320 50       5217 return $self->error('No name') unless $self->name;
362 320 50       6103 return $self->error('No data type') unless $self->data_type;
363 320 50       5151 return $self->error('No table object') unless $self->table;
364 320         5634 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 1     1 1 661 my $self = shift;
407 1         24 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 1     1 1 389 my $self = shift;
442 1 50 50     22 if ( my $table = $self->table ) { return $table->schema || undef; }
  1         35  
443 0         0 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 235     235   349 my $self = shift;
586 235         3386 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 Ekclark@cpan.orgE.
596              
597             =cut