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 71     71   1052 use Moo;
  71         172  
  71         531  
26 71     71   23994 use SQL::Translator::Schema::Constants;
  71         205  
  71         5871  
27 71     71   1053 use SQL::Translator::Types qw(schema_obj);
  71         307  
  71         3628  
28 71     71   504 use SQL::Translator::Utils qw(parse_list_arg ex2err throw carp_ro);
  71         250  
  71         4346  
29 71     71   545 use Sub::Quote qw(quote_sub);
  71         266  
  71         3131  
30 71     71   501 use Scalar::Util ();
  71         256  
  71         8526  
31              
32             extends 'SQL::Translator::Schema::Object';
33              
34             our $VERSION = '1.63';
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 3450     3450   79210 '""' => sub { shift->name },
41 14946 50   14946   490120 'bool' => sub { $_[0]->name || $_[0] },
42 71         1206 fallback => 1,
43 71     71   590 ;
  71         223  
44              
45 71     71   124568 use DBI qw(:sql_types);
  71         1236053  
  71         186857  
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 205     205   3000 map { $_ => 1 }
  1845         7661  
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 325 100   325   6684 $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 625     625   12793 my ( $self ) = @_;
217              
218 625 100       11740 if ( my $table = $self->table ) {
219 620 100       23106 if ( my $schema = $table->schema ) {
220 598 100 66     13075 if (
221             $schema->database eq 'PostgreSQL' &&
222             $self->data_type eq 'serial'
223             ) {
224 1         21 return 1;
225             }
226             }
227             }
228 624         11675 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 123     123   13602 my ( $self ) = @_;
248              
249 123 50       2284 if ( my $table = $self->table ) {
250 123         2775 for my $c ( $table->get_constraints ) {
251 216 100       6642 if ( $c->type eq FOREIGN_KEY ) {
252 48         937 my %fields = map { $_, 1 } $c->fields;
  48         187  
253 48 100       1730 if ( $fields{ $self->name } ) {
254 9         391 $self->foreign_key_reference( $c );
255 9         465 return 1;
256             }
257             }
258             }
259             }
260 114         3844 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 590     590   9954 my ( $self ) = @_;
310              
311 590 100       10951 if ( my $table = $self->table ) {
312 588 100       12604 if ( my $pk = $table->primary_key ) {
313 459         11144 my %fields = map { $_, 1 } $pk->fields;
  494         1926  
314 459   50     17188 return $fields{ $self->name } || 0;
315             }
316             }
317 131         2392 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 68     68   618 my ( $self ) = @_;
334              
335 68 50       1282 if ( my $table = $self->table ) {
336 68         1415 for my $c ( $table->get_constraints ) {
337 126 100       4042 if ( $c->type eq UNIQUE ) {
338 39         779 my %fields = map { $_, 1 } $c->fields;
  39         146  
339 39 100       1505 if ( $fields{ $self->name } ) {
340 6         237 return 1;
341             }
342             }
343             }
344             }
345 62         1954 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 287     287 1 505 my $self = shift;
361 287 50       5442 return $self->error('No name') unless $self->name;
362 287 50       6187 return $self->error('No data type') unless $self->data_type;
363 287 50       5467 return $self->error('No table object') unless $self->table;
364 287         6312 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 803 my $self = shift;
407 1         28 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 491 my $self = shift;
442 1 50 50     27 if ( my $table = $self->table ) { return $table->schema || undef; }
  1         38  
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 310     310   528 my $self = shift;
586 310         5287 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