1 package Test::SQL::Translator;
7 Test::SQL::Translator - Test::More test functions for the Schema objects.
14 use SQL::Translator::Schema::Constants;
16 use base qw(Exporter);
18 our $VERSION = '1.62';
31 # $ATTRIBUTES{ <schema_object_name> } = { <attribname> => <default>, ... }
36 default_value => undef,
42 is_auto_increment => 0,
45 # foreign_key_reference,
60 reference_fields => [],
61 reference_table => '',
81 perform_action_when => undef,
82 database_events => undef,
99 #primary_key => undef, # pkey constraint
103 constraints => undef,
111 procedures => undef, # [] when set
112 tables => undef, # [] when set
113 triggers => undef, # [] when set
114 views => undef, # [] when set
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 my ($hashref, $object_type) = @_;
126 if ( !exists $ATTRIBUTES{ $object_type } ) {
127 die "Can't add default attribs for unknown Schema "
128 . "object type '$object_type'.";
132 grep { !exists $hashref->{ $_ } }
133 keys %{ $ATTRIBUTES{ $object_type } }
135 $hashref->{ $attr } = $ATTRIBUTES{ $object_type }{ $attr }
141 # Format test name so it will prepend the test names used below.
145 $name = "$name - " if $name;
150 my ($f1,$test,$name) = @_;
151 my $t_name = t_name($name);
152 default_attribs($test,"field");
155 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.
161 my $full_name = $f1->table->name.".".$test->{name};
163 is( $f1->name, $test->{name}, "${t_name}Field '$full_name'" );
165 is( $f1->is_valid, $test->{is_valid},
166 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
168 is( $f1->data_type, $test->{data_type},
169 "$t_name type is '$test->{data_type}'" );
171 is( $f1->size, $test->{size}, "$t_name size is '$test->{size}'" );
173 is( $f1->default_value, $test->{default_value},
174 "$t_name default value is "
175 .(defined($test->{default_value}) ? "'$test->{default_value}'" : "UNDEF" )
178 is( $f1->is_nullable, $test->{is_nullable},
179 "$t_name ".($test->{is_nullable} ? 'can' : 'cannot').' be null' );
181 is( $f1->is_unique, $test->{is_unique},
182 "$t_name ".($test->{is_unique} ? 'can' : 'cannot').' be unique' );
184 is( $f1->is_primary_key, $test->{is_primary_key},
185 "$t_name is ".($test->{is_primary_key} ? '' : 'not ').'a primary_key' );
187 is( $f1->is_foreign_key, $test->{is_foreign_key},
188 "$t_name is ".($test->{is_foreign_key} ? '' : 'not').' a foreign_key' );
190 is( $f1->is_auto_increment, $test->{is_auto_increment},
192 .($test->{is_auto_increment} ? '' : 'not ').'an auto_increment' );
194 is( $f1->comments, $test->{comments}, "$t_name comments" );
196 is_deeply( { $f1->extra }, $test->{extra}, "$t_name extra" );
200 my ($obj,$test,$name) = @_;
201 my $t_name = t_name($name);
202 default_attribs($test,"constraint");
204 is( $obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'" );
206 is( $obj->type, $test->{type}, "$t_name type is '$test->{type}'" );
208 is( $obj->deferrable, $test->{deferrable},
209 "$t_name ".($test->{deferrable} ? 'can' : 'cannot').' be deferred' );
211 is( $obj->is_valid, $test->{is_valid},
212 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
214 is($obj->table->name,$test->{table},"$t_name table is '$test->{table}'" );
216 is( $obj->expression, $test->{expression},
217 "$t_name expression is '$test->{expression}'" );
219 is_deeply( [$obj->fields], $test->{fields},
220 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
222 is( $obj->reference_table, $test->{reference_table},
223 "$t_name reference_table is '$test->{reference_table}'" );
225 is_deeply( [$obj->reference_fields], $test->{reference_fields},
226 "$t_name reference_fields are '".join(",",@{$test->{reference_fields}})."'" );
228 is( $obj->match_type, $test->{match_type},
229 "$t_name match_type is '$test->{match_type}'" );
231 is( $obj->on_delete, $test->{on_delete},
232 "$t_name on_delete is '$test->{on_delete}'" );
234 is( $obj->on_update, $test->{on_update},
235 "$t_name on_update is '$test->{on_update}'" );
237 is_deeply( [$obj->options], $test->{options},
238 "$t_name options are '".join(",",@{$test->{options}})."'" );
240 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
244 my ($obj,$test,$name) = @_;
245 my $t_name = t_name($name);
246 default_attribs($test,"index");
248 is( $obj->name, $test->{name}, "${t_name}Index '$test->{name}'" );
250 is( $obj->is_valid, $test->{is_valid},
251 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
253 is( $obj->type, $test->{type}, "$t_name type is '$test->{type}'" );
255 is_deeply( [$obj->fields], $test->{fields},
256 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
258 is_deeply( [$obj->options], $test->{options},
259 "$t_name options are '".join(",",@{$test->{options}})."'" );
261 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
265 my ($obj,$test,$name) = @_;
266 my $t_name = t_name($name);
267 default_attribs($test,"index");
269 is( $obj->name, $test->{name}, "${t_name}Trigger '$test->{name}'" );
271 is( $obj->is_valid, $test->{is_valid},
272 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
274 is( $obj->perform_action_when, $test->{perform_action_when},
275 "$t_name perform_action_when is '$test->{perform_action_when}'" );
277 is( join(',', $obj->database_events), $test->{database_events},
278 sprintf("%s database_events is '%s'",
280 $test->{'database_events'},
284 is( $obj->on_table, $test->{on_table},
285 "$t_name on_table is '$test->{on_table}'" );
287 is( $obj->scope, $test->{scope}, "$t_name scope is '$test->{scope}'" )
288 if exists $test->{scope};
290 is( $obj->action, $test->{action}, "$t_name action is '$test->{action}'" );
292 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
296 my ($obj,$test,$name) = @_;
297 my $t_name = t_name($name);
298 default_attribs($test,"index");
300 #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
302 is( $obj->name, $test->{name}, "${t_name}View '$test->{name}'" );
304 is( $obj->is_valid, $test->{is_valid},
305 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
307 is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" );
309 is_deeply( [$obj->fields], $test->{fields},
310 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
312 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
316 my ($obj,$test,$name) = @_;
317 my $t_name = t_name($name);
318 default_attribs($test,"index");
320 #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
322 is( $obj->name, $test->{name}, "${t_name}Procedure '$test->{name}'" );
324 is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" );
326 is_deeply( [$obj->parameters], $test->{parameters},
327 "$t_name parameters are '".join(",",@{$test->{parameters}})."'" );
329 is( $obj->comments, $test->{comments},
330 "$t_name comments is '$test->{comments}'" );
332 is( $obj->owner, $test->{owner}, "$t_name owner is '$test->{owner}'" );
334 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
338 my ($obj,$test,$name) = @_;
339 my $t_name = t_name($name);
340 default_attribs($test,"table");
343 my $tbl_name = $arg{name} || die "Need a table name to test.";
344 is( $obj->{name}, $arg{name}, "${t_name}Table '$arg{name}'" );
346 is_deeply( [$obj->options], $test->{options},
347 "$t_name options are '".join(",",@{$test->{options}})."'" );
349 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
352 if ( $arg{fields} ) {
353 my @fldnames = map {$_->{name}} @{$arg{fields}};
355 [ map {$_->name} $obj->get_fields ],
357 "${t_name} field names are ".join(", ",@fldnames)
359 foreach ( @{$arg{fields}} ) {
360 my $f_name = $_->{name} || die "Need a field name to test.";
361 next unless my $fld = $obj->get_field($f_name);
362 field_ok( $fld, $_, $name );
366 is(scalar($obj->get_fields), undef,
367 "${t_name} has no fields.");
370 # Constraints and Indices
371 _test_kids($obj, $test, $name, {
372 constraint => 'constraints',
378 my ( $obj, $test, $name, $kids ) = @_;
379 my $t_name = t_name($name);
380 my $obj_name = ref $obj;
381 ($obj_name) = $obj_name =~ m/^.*::(.*)$/;
383 while ( my ( $object_type, $plural ) = each %$kids ) {
384 next unless defined $test->{ $plural };
386 if ( my @tests = @{ $test->{ $plural } } ) {
387 my $meth = "get_$plural";
388 my @objects = $obj->$meth;
389 is( scalar(@objects), scalar(@tests),
390 "${t_name}$obj_name has " . scalar(@tests) . " $plural"
393 for my $object (@objects) {
394 my $ans = { lc($obj_name) => $obj->name, %{ shift @tests } };
396 my $meth = "${object_type}_ok";
399 $meth->( $object, $ans, $name );
407 my ($obj,$test,$name) = @_;
408 my $t_name = t_name($name);
409 default_attribs($test,"schema");
411 is( $obj->name, $test->{name}, "${t_name}Schema name is '$test->{name}'" );
413 is( $obj->database, $test->{database},
414 "$t_name database is '$test->{database}'" );
416 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
418 is( $obj->is_valid, $test->{is_valid},
419 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
422 if ( $test->{tables} ) {
423 is_deeply( [ map {$_->name} $obj->get_tables ],
424 [ map {$_->{name}} @{$test->{tables}} ],
425 "${t_name} table names match" );
426 foreach ( @{$test->{tables}} ) {
427 my $t_name = $_->{name} || die "Need a table name to test.";
428 table_ok( $obj->get_table($t_name), $_, $name );
432 is(scalar($obj->get_tables), undef,
433 "${t_name} has no tables.");
436 # Procedures, Triggers, Views
437 _test_kids($obj, $test, $name, {
438 procedure => 'procedures',
439 trigger => 'triggers',
444 # maybe_plan($ntests, @modules)
446 # Calls plan $ntests if @modules can all be loaded; otherwise,
447 # calls skip_all with an explanation of why the tests were skipped.
449 my ($ntests, @modules) = @_;
452 for my $module (@modules) {
456 if ($@ =~ /Can't locate (\S+)/) {
462 elsif ($@ =~ /([\w\:]+ version [\d\.]+) required.+?this is only version/) {
465 elsif ($@ =~ /Can't load .+? for module .+?DynaLoader\.pm/i ) {
466 push @errors, $module;
469 (my $err = $@) =~ s/\n+/\\n/g; # Can't have newlines in the skip message
470 push @errors, "$module: $err";
475 my $msg = sprintf "Missing dependenc%s: %s",
476 @errors == 1 ? 'y' : 'ies',
478 plan skip_all => $msg;
480 return unless defined $ntests;
482 if ($ntests ne 'no_plan') {
483 plan tests => $ntests;
490 1; # compile please ===========================================================
501 use Test::SQL::Translator;
504 my $sqlt = SQL::Translator->new(
506 filename => "$Bin/data/magic/test.magic",
510 my $schema = $sqlt->schema;
512 # Test the table it produced.
513 table_ok( $schema->get_table("Customer"), {
517 name => "CustomerID",
520 default_value => undef,
526 data_type => "VARCHAR",
533 type => "PRIMARY KEY",
534 fields => "CustomerID",
547 Provides a set of Test::More tests for Schema objects. Testing a parsed
548 schema is then as easy as writing a perl data structure describing how you
549 expect the schema to look. Also provides C<maybe_plan> for conditionally running
550 tests based on their dependencies.
552 The data structures given to the test subs don't have to include all the
553 possible values, only the ones you expect to have changed. Any left out will be
554 tested to make sure they are still at their default value. This is a useful
555 check that you your parser hasn't accidentally set schema values you didn't
558 For an example of the output run the F<t/16xml-parser.t> test.
562 All the tests take a first arg of the schema object to test, followed by a
563 hash ref describing how you expect that object to look (you only need give the
564 attributes you expect to have changed from the default).
565 The 3rd arg is an optional test name to prepend to all the generated test
582 =head1 CONDITIONAL TESTS
584 The C<maybe_plan> function handles conditionally running an individual
585 test. It is here to enable running the test suite even when dependencies
586 are missing; not having (for example) GraphViz installed should not keep
587 the test suite from passing.
589 C<maybe_plan> takes the number of tests to (maybe) run, and a list of
590 modules on which test execution depends:
592 maybe_plan(180, 'SQL::Translator::Parser::MySQL');
594 If one of C<SQL::Translator::Parser::MySQL>'s dependencies does not exist,
595 then the test will be skipped.
597 Instead of a number of tests, you can pass C<undef> if you're using
598 C<done_testing()>, or C<'no_plan'> if you don't want a plan at all.
602 table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok,
609 =item Test the tests!
611 =item Test Count Constants
613 Constants to give the number of tests each C<*_ok> sub uses. e.g. How many tests
614 does C<field_ok> run? Can then use these to set up the test plan easily.
618 As the test subs wrap up lots of tests in one call you can't skip individual
619 tests only whole sets e.g. a whole table or field.
620 We could add C<skip_*> items to the test hashes to allow per test skips. e.g.
622 skip_is_primary_key => "Need to fix primary key parsing.",
624 =item yaml test specs
626 Maybe have the test subs also accept yaml for the test hash ref as it is much
627 nicer for writing big data structures. We can then define tests as in input
628 schema file and test yaml file to compare it against.
634 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
635 Darren Chamberlain <darren@cpan.org>.
637 Thanks to Ken Y. Clark for the original table and field test code taken from
642 perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.