File Coverage

blib/lib/Test/SQL/Translator.pm
Criterion Covered Total %
statement 181 191 94.7
branch 39 60 65.0
condition 4 8 50.0
subroutine 19 19 100.0
pod 7 11 63.6
total 250 289 86.5


line stmt bran cond sub pod time code
1             package Test::SQL::Translator;
2              
3             =pod
4              
5             =head1 NAME
6              
7             Test::SQL::Translator - Test::More test functions for the Schema objects.
8              
9             =cut
10              
11 100     100   4164500 use strict;
  99         164454  
  99         2800  
12 59     59   1449 use warnings;
  59         118  
  59         1248  
13 56     56   732 use Test::More;
  56         85033  
  56         291  
14 56     56   27791 use SQL::Translator::Schema::Constants;
  56         126  
  56         3374  
15              
16 56     56   299 use base qw(Exporter);
  56         92  
  56         127708  
17             our @EXPORT_OK;
18             our $VERSION = '1.6_3';
19             our @EXPORT = qw(
20             schema_ok
21             table_ok
22             field_ok
23             constraint_ok
24             index_ok
25             view_ok
26             trigger_ok
27             procedure_ok
28             maybe_plan
29             );
30              
31             # $ATTRIBUTES{ } = { => , ... }
32             my %ATTRIBUTES = (
33             field => {
34             name => undef,
35             data_type => '',
36             default_value => undef,
37             size => '0',
38             is_primary_key => 0,
39             is_unique => 0,
40             is_nullable => 1,
41             is_foreign_key => 0,
42             is_auto_increment => 0,
43             comments => '',
44             extra => {},
45             # foreign_key_reference,
46             is_valid => 1,
47             # order
48             },
49             constraint => {
50             name => '',
51             type => '',
52             deferrable => 1,
53             expression => '',
54             is_valid => 1,
55             fields => [],
56             match_type => '',
57             options => [],
58             on_delete => '',
59             on_update => '',
60             reference_fields => [],
61             reference_table => '',
62             extra => {},
63             },
64             index => {
65             fields => [],
66             is_valid => 1,
67             name => "",
68             options => [],
69             type => NORMAL,
70             extra => {},
71             },
72             view => {
73             name => "",
74             sql => "",
75             fields => [],
76             is_valid => 1,
77             extra => {},
78             },
79             trigger => {
80             name => '',
81             perform_action_when => undef,
82             database_events => undef,
83             on_table => undef,
84             action => undef,
85             is_valid => 1,
86             extra => {},
87             },
88             procedure => {
89             name => '',
90             sql => '',
91             parameters => [],
92             owner => '',
93             comments => '',
94             extra => {},
95             },
96             table => {
97             comments => undef,
98             name => '',
99             #primary_key => undef, # pkey constraint
100             options => [],
101             #order => 0,
102             fields => undef,
103             constraints => undef,
104             indices => undef,
105             is_valid => 1,
106             extra => {},
107             },
108             schema => {
109             name => '',
110             database => '',
111             procedures => undef, # [] when set
112             tables => undef, # [] when set
113             triggers => undef, # [] when set
114             views => undef, # [] when set
115             is_valid => 1,
116             extra => {},
117             }
118             );
119              
120             # Given a test hash and schema object name set any attribute keys not present in
121             # the test hash to their default value for that schema object type.
122             # e.g. default_attribs( $test, "field" );
123             sub default_attribs {
124 35     35 0 78 my ($hashref, $object_type) = @_;
125              
126 35 50       99 if ( !exists $ATTRIBUTES{ $object_type } ) {
127 0         0 die "Can't add default attribs for unknown Schema "
128             . "object type '$object_type'.";
129             }
130              
131 35         53 for my $attr (
132 374         570 grep { !exists $hashref->{ $_ } }
133 35         177 keys %{ $ATTRIBUTES{ $object_type } }
134             ) {
135 238         434 $hashref->{ $attr } = $ATTRIBUTES{ $object_type }{ $attr }
136             }
137              
138 35         81 return $hashref;
139             }
140              
141             # Format test name so it will prepend the test names used below.
142             sub t_name {
143 40     40 0 71 my $name = shift;
144 40   50     212 $name ||= "";
145 40 50       101 $name = "$name - " if $name;
146 40         77 return $name;
147             }
148              
149             sub field_ok {
150 21     21 1 57 my ($f1,$test,$name) = @_;
151 21         54 my $t_name = t_name($name);
152 21         62 default_attribs($test,"field");
153              
154 21 50       60 unless ($f1) {
155 0         0 fail " Field '$test->{name}' doesn't exist!";
156             # TODO Do a skip on the following tests. Currently the test counts wont
157             # match at the end. So at least it fails.
158 0         0 return;
159             }
160              
161 21         658 my $full_name = $f1->table->name.".".$test->{name};
162              
163 21         674 is( $f1->name, $test->{name}, "${t_name}Field '$full_name'" );
164              
165             is( $f1->is_valid, $test->{is_valid},
166 21 50       7266 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
167              
168             is( $f1->data_type, $test->{data_type},
169 21         7020 "$t_name type is '$test->{data_type}'" );
170              
171 21         7465 is( $f1->size, $test->{size}, "$t_name size is '$test->{size}'" );
172              
173             is( $f1->default_value, $test->{default_value},
174             "$t_name default value is "
175 21 100       7042 .(defined($test->{default_value}) ? "'$test->{default_value}'" : "UNDEF" )
176             );
177              
178             is( $f1->is_nullable, $test->{is_nullable},
179 21 100       7998 "$t_name ".($test->{is_nullable} ? 'can' : 'cannot').' be null' );
180              
181             is( $f1->is_unique, $test->{is_unique},
182 21 100       7301 "$t_name ".($test->{is_unique} ? 'can' : 'cannot').' be unique' );
183              
184             is( $f1->is_primary_key, $test->{is_primary_key},
185 21 100       7314 "$t_name is ".($test->{is_primary_key} ? '' : 'not ').'a primary_key' );
186              
187             is( $f1->is_foreign_key, $test->{is_foreign_key},
188 21 100       7179 "$t_name is ".($test->{is_foreign_key} ? '' : 'not').' a foreign_key' );
189              
190             is( $f1->is_auto_increment, $test->{is_auto_increment},
191             "$t_name is "
192 21 100       7634 .($test->{is_auto_increment} ? '' : 'not ').'an auto_increment' );
193              
194 21         7450 is( $f1->comments, $test->{comments}, "$t_name comments" );
195              
196 21         7214 is_deeply( { $f1->extra }, $test->{extra}, "$t_name extra" );
197             }
198              
199             sub constraint_ok {
200 4     4 1 8 my ($obj,$test,$name) = @_;
201 4         7 my $t_name = t_name($name);
202 4         9 default_attribs($test,"constraint");
203              
204 4         71 is( $obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'" );
205              
206 4         1532 is( $obj->type, $test->{type}, "$t_name type is '$test->{type}'" );
207              
208             is( $obj->deferrable, $test->{deferrable},
209 4 50       1518 "$t_name ".($test->{deferrable} ? 'can' : 'cannot').' be deferred' );
210              
211             is( $obj->is_valid, $test->{is_valid},
212 4 50       1517 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
213              
214 4         1571 is($obj->table->name,$test->{table},"$t_name table is '$test->{table}'" );
215              
216             is( $obj->expression, $test->{expression},
217 4         1545 "$t_name expression is '$test->{expression}'" );
218              
219             is_deeply( [$obj->fields], $test->{fields},
220 4         1457 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
  4         20  
221              
222             is( $obj->reference_table, $test->{reference_table},
223 4         1787 "$t_name reference_table is '$test->{reference_table}'" );
224              
225             is_deeply( [$obj->reference_fields], $test->{reference_fields},
226 4         1534 "$t_name reference_fields are '".join(",",@{$test->{reference_fields}})."'" );
  4         18  
227              
228             is( $obj->match_type, $test->{match_type},
229 4         2113 "$t_name match_type is '$test->{match_type}'" );
230              
231             is( $obj->on_delete, $test->{on_delete},
232 4         1557 "$t_name on_delete is '$test->{on_delete}'" );
233              
234             is( $obj->on_update, $test->{on_update},
235 4         1527 "$t_name on_update is '$test->{on_update}'" );
236              
237             is_deeply( [$obj->options], $test->{options},
238 4         1564 "$t_name options are '".join(",",@{$test->{options}})."'" );
  4         19  
239              
240 4         2204 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
241             }
242              
243             sub index_ok {
244 1     1 1 2 my ($obj,$test,$name) = @_;
245 1         3 my $t_name = t_name($name);
246 1         4 default_attribs($test,"index");
247              
248 1         20 is( $obj->name, $test->{name}, "${t_name}Index '$test->{name}'" );
249              
250             is( $obj->is_valid, $test->{is_valid},
251 1 50       365 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
252              
253 1         394 is( $obj->type, $test->{type}, "$t_name type is '$test->{type}'" );
254              
255             is_deeply( [$obj->fields], $test->{fields},
256 1         385 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
  1         6  
257              
258             is_deeply( [$obj->options], $test->{options},
259 1         582 "$t_name options are '".join(",",@{$test->{options}})."'" );
  1         7  
260              
261 1         549 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
262             }
263              
264             sub trigger_ok {
265 2     2 1 5 my ($obj,$test,$name) = @_;
266 2         4 my $t_name = t_name($name);
267 2         6 default_attribs($test,"index");
268              
269 2         12 is( $obj->name, $test->{name}, "${t_name}Trigger '$test->{name}'" );
270              
271             is( $obj->is_valid, $test->{is_valid},
272 2 50       756 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
273              
274             is( $obj->perform_action_when, $test->{perform_action_when},
275 2         771 "$t_name perform_action_when is '$test->{perform_action_when}'" );
276              
277             is( join(',', $obj->database_events), $test->{database_events},
278             sprintf("%s database_events is '%s'",
279             $t_name,
280 2         777 $test->{'database_events'},
281             )
282             );
283              
284             is( $obj->on_table, $test->{on_table},
285 2         721 "$t_name on_table is '$test->{on_table}'" );
286              
287             is( $obj->scope, $test->{scope}, "$t_name scope is '$test->{scope}'" )
288 2 50       793 if exists $test->{scope};
289              
290 2         731 is( $obj->action, $test->{action}, "$t_name action is '$test->{action}'" );
291              
292 2         755 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
293             }
294              
295             sub view_ok {
296 1     1 1 3 my ($obj,$test,$name) = @_;
297 1         2 my $t_name = t_name($name);
298 1         3 default_attribs($test,"index");
299              
300             #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
301              
302 1         8 is( $obj->name, $test->{name}, "${t_name}View '$test->{name}'" );
303              
304             is( $obj->is_valid, $test->{is_valid},
305 1 50       373 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
306              
307 1         367 is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" );
308              
309             is_deeply( [$obj->fields], $test->{fields},
310 1         383 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
  1         6  
311              
312 1         563 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
313             }
314              
315             sub procedure_ok {
316 1     1 1 3 my ($obj,$test,$name) = @_;
317 1         3 my $t_name = t_name($name);
318 1         3 default_attribs($test,"index");
319              
320             #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
321              
322 1         9 is( $obj->name, $test->{name}, "${t_name}Procedure '$test->{name}'" );
323              
324 1         385 is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" );
325              
326             is_deeply( [$obj->parameters], $test->{parameters},
327 1         396 "$t_name parameters are '".join(",",@{$test->{parameters}})."'" );
  1         8  
328              
329             is( $obj->comments, $test->{comments},
330 1         571 "$t_name comments is '$test->{comments}'" );
331              
332 1         365 is( $obj->owner, $test->{owner}, "$t_name owner is '$test->{owner}'" );
333              
334 1         388 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
335             }
336              
337             sub table_ok {
338 4     4 1 13 my ($obj,$test,$name) = @_;
339 4         12 my $t_name = t_name($name);
340 4         16 default_attribs($test,"table");
341 4         24 my %arg = %$test;
342              
343 4   50     16 my $tbl_name = $arg{name} || die "Need a table name to test.";
344 4         27 is( $obj->{name}, $arg{name}, "${t_name}Table '$arg{name}'" );
345              
346             is_deeply( [$obj->options], $test->{options},
347 4         1454 "$t_name options are '".join(",",@{$test->{options}})."'" );
  4         29  
348              
349 4         2383 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
350              
351             # Fields
352 4 50       2057 if ( $arg{fields} ) {
353 4         12 my @fldnames = map {$_->{name}} @{$arg{fields}};
  21         41  
  4         13  
354             is_deeply(
355 4         26 [ map {$_->name} $obj->get_fields ],
  21         586  
356             [ @fldnames ],
357             "${t_name} field names are ".join(", ",@fldnames)
358             );
359 4         2376 foreach ( @{$arg{fields}} ) {
  4         16  
360 21   50     9081 my $f_name = $_->{name} || die "Need a field name to test.";
361 21 50       103 next unless my $fld = $obj->get_field($f_name);
362 21         407 field_ok( $fld, $_, $name );
363             }
364             }
365             else {
366 0         0 is(scalar($obj->get_fields), undef,
367             "${t_name} has no fields.");
368             }
369              
370             # Constraints and Indices
371 4         2110 _test_kids($obj, $test, $name, {
372             constraint => 'constraints',
373             index => 'indices',
374             });
375             }
376              
377             sub _test_kids {
378 5     5   17 my ( $obj, $test, $name, $kids ) = @_;
379 5         14 my $t_name = t_name($name);
380 5         15 my $obj_name = ref $obj;
381 5         31 ($obj_name) = $obj_name =~ m/^.*::(.*)$/;
382              
383 5         27 while ( my ( $object_type, $plural ) = each %$kids ) {
384 11 100       2384 next unless defined $test->{ $plural };
385              
386 5 50       18 if ( my @tests = @{ $test->{ $plural } } ) {
  5         16  
387 5         11 my $meth = "get_$plural";
388 5         21 my @objects = $obj->$meth;
389 5         37 is( scalar(@objects), scalar(@tests),
390             "${t_name}$obj_name has " . scalar(@tests) . " $plural"
391             );
392              
393 5         1796 for my $object (@objects) {
394 9         2362 my $ans = { lc($obj_name) => $obj->name, %{ shift @tests } };
  9         139  
395              
396 9         20 my $meth = "${object_type}_ok";
397             {
398 56     56   556 no strict 'refs';
  56         132  
  56         36850  
  9         10  
399 9         29 $meth->( $object, $ans, $name );
400             }
401             }
402             }
403             }
404             }
405              
406             sub schema_ok {
407 1     1 0 94 my ($obj,$test,$name) = @_;
408 1         9 my $t_name = t_name($name);
409 1         4 default_attribs($test,"schema");
410              
411 1         9 is( $obj->name, $test->{name}, "${t_name}Schema name is '$test->{name}'" );
412              
413             is( $obj->database, $test->{database},
414 1         390 "$t_name database is '$test->{database}'" );
415              
416 1         401 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
417              
418             is( $obj->is_valid, $test->{is_valid},
419 1 50       577 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
420              
421             # Tables
422 1 50       394 if ( $test->{tables} ) {
423 2         47 is_deeply( [ map {$_->name} $obj->get_tables ],
424 1         5 [ map {$_->{name}} @{$test->{tables}} ],
  2         8  
  1         18  
425             "${t_name} table names match" );
426 1         567 foreach ( @{$test->{tables}} ) {
  1         4  
427 2   50     581 my $t_name = $_->{name} || die "Need a table name to test.";
428 2         9 table_ok( $obj->get_table($t_name), $_, $name );
429             }
430             }
431             else {
432 0         0 is(scalar($obj->get_tables), undef,
433             "${t_name} has no tables.");
434             }
435              
436             # Procedures, Triggers, Views
437 1         6 _test_kids($obj, $test, $name, {
438             procedure => 'procedures',
439             trigger => 'triggers',
440             view => 'views',
441             });
442             }
443              
444             # maybe_plan($ntests, @modules)
445             #
446             # Calls plan $ntests if @modules can all be loaded; otherwise,
447             # calls skip_all with an explanation of why the tests were skipped.
448             sub maybe_plan {
449 49     49 0 121832 my ($ntests, @modules) = @_;
450 49         110 my @errors;
451              
452 49         326 for my $module (@modules) {
453 49     49   21448 eval "use $module;";
  47         115887  
  47         1430  
  96         5013  
454 96 100       573 next if !$@;
455              
456 3 50       19 if ($@ =~ /Can't locate (\S+)/) {
    0          
    0          
457 3         10 my $mod = $1;
458 3         11 $mod =~ s/\.pm$//;
459 3         8 $mod =~ s#/#::#g;
460 3         11 push @errors, $mod;
461             }
462             elsif ($@ =~ /([\w\:]+ version [\d\.]+) required.+?this is only version/) {
463 0         0 push @errors, $1;
464             }
465             elsif ($@ =~ /Can't load .+? for module .+?DynaLoader\.pm/i ) {
466 0         0 push @errors, $module;
467             }
468             else {
469 0         0 (my $err = $@) =~ s/\n+/\\n/g; # Can't have newlines in the skip message
470 0         0 push @errors, "$module: $err";
471             }
472             }
473              
474 49 100       235 if (@errors) {
475 2 100       16 my $msg = sprintf "Missing dependenc%s: %s",
476             @errors == 1 ? 'y' : 'ies',
477             join ", ", @errors;
478 2         11 plan skip_all => $msg;
479             }
480 47 100       4991 return unless defined $ntests;
481              
482 41 50       289 if ($ntests ne 'no_plan') {
483 41         239 plan tests => $ntests;
484             }
485             else {
486 0           plan 'no_plan';
487             }
488             }
489              
490             1; # compile please ===========================================================
491             __END__