File Coverage

blib/lib/DBIx/Schema/DSL.pm
Criterion Covered Total %
statement 186 196 94.9
branch 49 60 81.6
condition 20 38 52.6
subroutine 39 42 92.8
pod 23 23 100.0
total 317 359 88.3


line stmt bran cond sub pod time code
1             package DBIx::Schema::DSL;
2 8     8   155987 use 5.008_001;
  8         28  
3 8     8   47 use strict;
  8         12  
  8         211  
4 8     8   37 use warnings;
  8         16  
  8         533  
5              
6             our $VERSION = '0.12';
7              
8 8     8   37 use Carp qw/croak/;
  8         14  
  8         652  
9 8     8   5127 use Array::Diff;
  8         146769  
  8         71  
10 8     8   4704 use DBIx::Schema::DSL::Context;
  8         23  
  8         330  
11 8     8   58 use SQL::Translator::Schema::Constants;
  8         9  
  8         646  
12 8     8   39 use SQL::Translator::Schema::Field;
  8         9  
  8         429  
13              
14             sub context {
15 105     105 1 2887 my $pkg = shift;
16 105 50       198 die 'something wrong when calling context method.' if $pkg eq __PACKAGE__;
17 8     8   37 no strict 'refs';
  8         13  
  8         571  
18 105   66     89 ${"$pkg\::CONTEXT"} ||= DBIx::Schema::DSL::Context->new;
  105         727  
19             }
20              
21             # don't override CORE::int
22 8     8   5326 use Pod::Functions ();
  8         19273  
  8         1179  
23             my @column_methods =
24             grep {!$Pod::Functions::Type{$_}} grep { /^[a-zA-Z_][0-9a-zA-Z_]*$/ } keys(%SQL::Translator::Schema::Field::type_mapping), qw/string number enum set/;
25             my @column_sugars = qw/unique auto_increment unsigned null/;
26             my @rev_column_sugars = qw/not_null signed/;
27             my @export_dsls = qw/
28             create_database database create_table column primary_key set_primary_key add_index add_unique_index
29             foreign_key has_many has_one belongs_to add_table_options default_unsigned columns pk fk
30             default_not_null
31             /;
32             my @class_methods = qw/context output no_fk_output translate_to translator/;
33             sub import {
34 13     13   108 my $caller = caller;
35              
36 8     8   50 no strict 'refs';
  8         10  
  8         13807  
37 13         45 for my $func (@export_dsls, @column_methods, @column_sugars, @class_methods, @rev_column_sugars) {
38 702         740 *{"$caller\::$func"} = \&$func;
  702         15526  
39             }
40             }
41              
42 3     3 1 59 sub create_database($) { caller->context->name(shift) }
43 3     3 1 32 sub database($) { caller->context->db(shift) }
44              
45             sub add_table_options {
46 3     3 1 18 my $c = caller->context;
47 3         22 my %opt = @_;
48              
49             $c->set_table_extra({
50 3         7 %{$c->table_extra},
  3         23  
51             %opt,
52             });
53              
54 3 50 33     28 if ($opt{mysql_charset} && $opt{mysql_charset} eq 'utf8mb4') {
55 3         14 $c->default_varchar_size(191);
56             }
57             }
58              
59             sub default_unsigned() {
60 2     2 1 14 caller->context->default_unsigned(1);
61             }
62              
63             sub default_not_null() {
64 1     1 1 3 caller->context->default_not_null(1);
65             }
66              
67             sub create_table($$) {
68 17     17 1 41 my ($table_name, $code) = @_;
69              
70 17         33 my $kls = caller;
71 17         81 my $c = $kls->context;
72              
73 17         238 $c->_creating_table({
74             table_name => $table_name,
75             columns => [],
76             indices => [],
77             constraints => [],
78             primary_key => undef,
79             });
80              
81 17         40 $code->();
82              
83 15         35 my $data = $c->_creating_table;
84             my $table = $c->schema->add_table(
85             name => $table_name,
86 15         275 extra => {%{$c->table_extra}},
  15         846  
87             );
88 15         10157 for my $column (@{ $data->{columns} }) {
  15         50  
89 52         41500 $table->add_field(%{ $column } );
  52         221  
90             }
91              
92 15         19737 my @columns = map {$_->{name}} @{$data->{columns}};
  52         104  
  15         49  
93 15         24 for my $index (@{ $data->{indices} }) {
  15         48  
94 3 100       15 if (my @undefined_columns = _detect_undefined_columns(\@columns, $index->{fields})) {
95 1         19 croak "Index error: Key column [@{[join ', ', @undefined_columns]}] doesn't exist in table]";
  1         162  
96             }
97 2         24 $table->add_index(%{ $index } );
  2         14  
98             }
99 14         2482 for my $constraint (@{ $data->{constraints} }) {
  14         44  
100 8         19 my $cols = $constraint->{fields};
101 8 100       62 $cols = [$cols] unless ref $cols;
102 8 50       55 if (my @undefined_columns = _detect_undefined_columns(\@columns, $cols)) {
103 0         0 croak "Constraint error: Key column [@{[join ', ', @undefined_columns]}] doesn't exist in table]";
  0         0  
104             }
105 8         82 $table->add_constraint(%{ $constraint } );
  8         54  
106             }
107              
108 14 100       8117 if (my $pk = $data->{primary_key}) {
109 12 100       46 $pk = [$pk] unless ref $pk;
110 12 100       71 if (my @undefined_columns = _detect_undefined_columns(\@columns, $pk)) {
111 1         8 croak "Primary key error: Key column [@{[join ', ', @undefined_columns]}] doesn't exist in table]";
  1         110  
112             }
113 11         121 $table->primary_key($data->{primary_key});
114             }
115              
116 13         25721 $c->_clear_creating_table;
117             }
118 17     17 1 1755 sub columns(&) {shift}
119              
120             sub _detect_undefined_columns {
121 23     23   35 my ($set, $subset) = @_;
122              
123 23         244 my $diff = Array::Diff->diff([sort @$set], [sort @$subset]);
124 23         6153 @{$diff->added};
  23         66  
125             }
126              
127             sub column($$;%) {
128 56     56 1 87 my ($column_name, $data_type, @opt) = @_;
129 56 100       244 croak '`column` function called in non void context' if defined wantarray;
130              
131 55 100       114 if (ref $opt[0] eq 'ARRAY') {
132             # enum or set
133 1         2 unshift @opt, 'list';
134             }
135              
136 55 100       110 if (@opt % 2) {
137 1         2 croak "odd number elements are assined to options. arguments: [@{[join ', ', @_]}]";
  1         136  
138             }
139 54         95 my %opt = @opt;
140 54 50       99 $data_type = 'varchar' if $data_type eq 'string';
141              
142 54         124 my $c = caller->context;
143              
144 54 50       140 my $creating_data = $c->_creating_table
145             or croak q{can't call `column` method outside `create_table` method};
146              
147 54         157 my %args = (
148             name => $column_name,
149             data_type => uc $data_type,
150             );
151              
152 54         189 my %map = (
153             null => 'is_nullable',
154             limit => 'size',
155             default => 'default_value',
156             unique => 'is_unique',
157             primary_key => 'is_primary_key',
158             auto_increment => 'is_auto_increment',
159             );
160 54         121 for my $key (keys %map) {
161 324 100       561 $args{$map{$key}} = delete $opt{$key} if exists $opt{$key};
162             }
163             %args = (
164 54         198 %args,
165             %opt
166             );
167              
168 54 100 100     290 if (exists $args{unsigned}) {
    100          
169 3         7 $args{extra}{unsigned} = delete $args{unsigned};
170             }
171             elsif ($c->default_unsigned && $data_type =~ /int(?:eger)?$/) {
172 9         21 $args{extra}{unsigned} = 1;
173             }
174              
175 54 100       92 if (exists $args{on_update}) {
176 1         2 $args{extra}{'on update'} = delete $args{on_update};
177             }
178              
179 54 100       93 if (exists $args{list}) {
180 1         5 $args{extra}{list} = delete $args{list};
181             }
182              
183              
184 54 100 100     204 if ( !exists $args{is_nullable} && $c->default_not_null ) {
185 2         3 $args{is_nullable} = 0;
186             }
187              
188 54 100 66     148 if ($args{data_type} eq 'VARCHAR' && !$args{size}) {
189 15         39 $args{size} = $c->default_varchar_size;
190             }
191              
192 54 100       94 if ($args{precision}) {
193 2         5 my $precision = delete $args{precision};
194 2   50     9 my $scale = delete $args{scale} || 0;
195 2         7 $args{size} = [$precision, $scale];
196             }
197              
198 54 100       126 if ($args{is_primary_key}) {
    100          
199 12         22 $creating_data->{primary_key} = $column_name;
200             }
201             elsif ($args{is_unique}) {
202 5         7 push @{$creating_data->{constraints}}, {
  5         29  
203             name => "${column_name}_uniq",
204             fields => [$column_name],
205             type => UNIQUE,
206             };
207             }
208              
209             # explicitly add `DEFAULT NULL` if is_nullable and not specified default_value
210 54 50 66     182 if ($args{is_nullable} && !exists $args{default_value} && $args{data_type} !~ /^(?:TINY|MEDIUM|LONG)?(?:TEXT|BLOB)$/ ) {
      66        
211 10         14 $args{default_value} = \'NULL';
212             }
213              
214 54         49 push @{$creating_data->{columns}}, \%args;
  54         242  
215             }
216              
217             sub primary_key {
218 9 100   9 1 92 if (defined wantarray) {
219 7         32 (primary_key => 1);
220             }
221             else { # void context
222 2         5 my $column_name = shift;
223              
224 2         9 @_ = ($column_name, 'integer', primary_key(), auto_increment(), @_);
225 2         9 goto \&column;
226             }
227             }
228             *pk = \&primary_key;
229              
230             for my $method (@column_methods) {
231 8     8   49 no strict 'refs';
  8         15  
  8         479  
232             *{__PACKAGE__."::$method"} = sub {
233 8     8   39 use strict 'refs';
  8         13  
  8         651  
234 51     51   94 my $column_name = shift;
235              
236 51         146 @_ = ($column_name, $method, @_);
237 51         113 goto \&column;
238             };
239             }
240              
241             for my $method (@column_sugars) {
242 8     8   39 no strict 'refs';
  8         11  
  8         377  
243             *{__PACKAGE__."::$method"} = sub() {
244 8     8   38 use strict 'refs';
  8         13  
  8         5491  
245 20     20   97 ($method => 1);
246             };
247             }
248 0     0 1 0 sub not_null() { (null => 0) }
249 0     0 1 0 sub signed() { (unsigned => 0) }
250              
251             sub set_primary_key(@) {
252 3     3 1 8 my @keys = @_;
253              
254 3         14 my $c = caller->context;
255              
256 3 50       19 my $creating_data = $c->_creating_table
257             or die q{can't call `set_primary_key` method outside `create_table` method};
258              
259 3         11 $creating_data->{primary_key} = \@keys;
260             }
261              
262             sub add_index {
263 2     2 1 8 my $c = caller->context;
264              
265 2 50       12 my $creating_data = $c->_creating_table
266             or die q{can't call `add_index` method outside `create_table` method};
267              
268 2         6 my ($idx_name, $fields, $type) = @_;
269              
270 2 50       4 push @{$creating_data->{indices}}, {
  2         13  
271             name => $idx_name,
272             fields => $fields,
273             ($type ? (type => $type) : ()),
274             };
275             }
276              
277             sub add_unique_index {
278 1     1 1 3 my $c = caller->context;
279              
280 1 50       4 my $creating_data = $c->_creating_table
281             or die q{can't call `add_unique_index` method outside `create_table` method};
282              
283 1         2 my ($idx_name, $fields) = @_;
284              
285 1         1 push @{$creating_data->{indices}}, {
  1         3  
286             name => $idx_name,
287             fields => $fields,
288             type => UNIQUE,
289             };
290             }
291              
292             sub foreign_key {
293 4     4 1 15 my $c = caller->context;
294              
295 4 50       16 my $creating_data = $c->_creating_table
296             or die q{can't call `foreign` method outside `create_table` method};
297              
298 4         9 my ($columns, $table, $foreign_columns, %opt) = @_;
299              
300 4         6 push @{$creating_data->{constraints}}, {
  4         28  
301             type => FOREIGN_KEY,
302             fields => $columns,
303             reference_table => $table,
304             reference_fields => $foreign_columns,
305             %opt,
306             };
307             }
308             *fk = \&foreign_key;
309              
310             sub has_many {
311 2     2 1 16 my $c = caller->context;
312              
313 2         6 my ($table, %opt) = @_;
314              
315 2   50     16 my $columns = delete $opt{column} || 'id';
316 2   33     17 my $foreign_columns = delete $opt{foreign_column} || $c->_creating_table_name .'_id';
317              
318 2         10 @_ = ($columns, $table, $foreign_columns, %opt);
319 2         10 goto \&foreign_key;
320             }
321              
322             sub has_one {
323 0     0 1 0 my $c = caller->context;
324              
325 0         0 my ($table, %opt) = @_;
326              
327 0   0     0 my $columns = delete $opt{column} || 'id';
328 0   0     0 my $foreign_columns = delete $opt{foreign_column} || $c->_creating_table_name .'_id';
329              
330 0         0 @_ = ($columns, $table, $foreign_columns, %opt);
331 0         0 goto \&foreign_key;
332             }
333              
334             sub belongs_to {
335 2     2 1 5 my ($table, %opt) = @_;
336              
337 2   33     11 my $columns = delete $opt{column} || "${table}_id";
338 2   50     12 my $foreign_columns = delete $opt{foreign_column} || 'id';
339              
340 2         7 @_ = ($columns, $table, $foreign_columns, %opt);
341 2         8 goto \&foreign_key;
342             }
343              
344             sub output {
345 5     5 1 17697 shift->context->translate;
346             }
347              
348             sub no_fk_output {
349 1     1 1 2855 shift->context->no_fk_translate;
350             }
351              
352             sub translator {
353 1     1 1 3 shift->context->translator;
354             }
355              
356             sub translate_to {
357 1     1 1 2 my ($kls, $db_type) = @_;
358              
359 1         4 $kls->translator->translate(to => $db_type);
360             }
361              
362             1;
363             __END__