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