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.59';
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->action, $test->{action}, "$t_name action is '$test->{action}'" );
289 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
293 my ($obj,$test,$name) = @_;
294 my $t_name = t_name($name);
295 default_attribs($test,"index");
297 #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
299 is( $obj->name, $test->{name}, "${t_name}View '$test->{name}'" );
301 is( $obj->is_valid, $test->{is_valid},
302 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
304 is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" );
306 is_deeply( [$obj->fields], $test->{fields},
307 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
309 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
313 my ($obj,$test,$name) = @_;
314 my $t_name = t_name($name);
315 default_attribs($test,"index");
317 #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
319 is( $obj->name, $test->{name}, "${t_name}Procedure '$test->{name}'" );
321 is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" );
323 is_deeply( [$obj->parameters], $test->{parameters},
324 "$t_name parameters are '".join(",",@{$test->{parameters}})."'" );
326 is( $obj->comments, $test->{comments},
327 "$t_name comments is '$test->{comments}'" );
329 is( $obj->owner, $test->{owner}, "$t_name owner is '$test->{owner}'" );
331 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
335 my ($obj,$test,$name) = @_;
336 my $t_name = t_name($name);
337 default_attribs($test,"table");
340 my $tbl_name = $arg{name} || die "Need a table name to test.";
341 is( $obj->{name}, $arg{name}, "${t_name}Table '$arg{name}'" );
343 is_deeply( [$obj->options], $test->{options},
344 "$t_name options are '".join(",",@{$test->{options}})."'" );
346 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
349 if ( $arg{fields} ) {
350 my @fldnames = map {$_->{name}} @{$arg{fields}};
352 [ map {$_->name} $obj->get_fields ],
354 "${t_name} field names are ".join(", ",@fldnames)
356 foreach ( @{$arg{fields}} ) {
357 my $f_name = $_->{name} || die "Need a field name to test.";
358 next unless my $fld = $obj->get_field($f_name);
359 field_ok( $fld, $_, $name );
363 is(scalar($obj->get_fields), undef,
364 "${t_name} has no fields.");
367 # Constraints and Indices
368 _test_kids($obj, $test, $name, {
369 constraint => 'constraints',
375 my ( $obj, $test, $name, $kids ) = @_;
376 my $t_name = t_name($name);
377 my $obj_name = ref $obj;
378 ($obj_name) = $obj_name =~ m/^.*::(.*)$/;
380 while ( my ( $object_type, $plural ) = each %$kids ) {
381 next unless defined $test->{ $plural };
383 if ( my @tests = @{ $test->{ $plural } } ) {
384 my $meth = "get_$plural";
385 my @objects = $obj->$meth;
386 is( scalar(@objects), scalar(@tests),
387 "${t_name}$obj_name has " . scalar(@tests) . " $plural"
390 for my $object (@objects) {
391 my $ans = { lc($obj_name) => $obj->name, %{ shift @tests } };
393 my $meth = "${object_type}_ok";
396 $meth->( $object, $ans, $name );
404 my ($obj,$test,$name) = @_;
405 my $t_name = t_name($name);
406 default_attribs($test,"schema");
408 is( $obj->name, $test->{name}, "${t_name}Schema name is '$test->{name}'" );
410 is( $obj->database, $test->{database},
411 "$t_name database is '$test->{database}'" );
413 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
415 is( $obj->is_valid, $test->{is_valid},
416 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
419 if ( $test->{tables} ) {
420 is_deeply( [ map {$_->name} $obj->get_tables ],
421 [ map {$_->{name}} @{$test->{tables}} ],
422 "${t_name} table names match" );
423 foreach ( @{$test->{tables}} ) {
424 my $t_name = $_->{name} || die "Need a table name to test.";
425 table_ok( $obj->get_table($t_name), $_, $name );
429 is(scalar($obj->get_tables), undef,
430 "${t_name} has no tables.");
433 # Procedures, Triggers, Views
434 _test_kids($obj, $test, $name, {
435 procedure => 'procedures',
436 trigger => 'triggers',
441 # maybe_plan($ntests, @modules)
443 # Calls plan $ntests if @modules can all be loaded; otherwise,
444 # calls skip_all with an explanation of why the tests were skipped.
446 my ($ntests, @modules) = @_;
449 for my $module (@modules) {
453 if ($@ =~ /Can't locate (\S+)/) {
459 elsif ($@ =~ /([\w\:]+ version [\d\.]+) required.+?this is only version/) {
462 elsif ($@ =~ /Can't load .+? for module .+?DynaLoader\.pm/i ) {
463 push @errors, $module;
468 my $msg = sprintf "Missing dependenc%s: %s",
469 @errors == 1 ? 'y' : 'ies',
471 plan skip_all => $msg;
473 return unless defined $ntests;
475 if ($ntests ne 'no_plan') {
476 plan tests => $ntests;
483 1; # compile please ===========================================================
494 use Test::SQL::Translator;
497 my $sqlt = SQL::Translator->new(
499 filename => "$Bin/data/magic/test.magic",
503 my $schema = $sqlt->schema;
505 # Test the table it produced.
506 table_ok( $schema->get_table("Customer"), {
510 name => "CustomerID",
513 default_value => undef,
519 data_type => "VARCHAR",
526 type => "PRIMARY KEY",
527 fields => "CustomerID",
540 Provides a set of Test::More tests for Schema objects. Testing a parsed
541 schema is then as easy as writing a perl data structure describing how you
542 expect the schema to look. Also provides C<maybe_plan> for conditionally running
543 tests based on their dependencies.
545 The data structures given to the test subs don't have to include all the
546 possible values, only the ones you expect to have changed. Any left out will be
547 tested to make sure they are still at their default value. This is a useful
548 check that you your parser hasn't accidentally set schema values you didn't
551 For an example of the output run the F<t/16xml-parser.t> test.
555 All the tests take a first arg of the schema object to test, followed by a
556 hash ref describing how you expect that object to look (you only need give the
557 attributes you expect to have changed from the default).
558 The 3rd arg is an optional test name to prepend to all the generated test
575 =head1 CONDITIONAL TESTS
577 The C<maybe_plan> function handles conditionally running an individual
578 test. It is here to enable running the test suite even when dependencies
579 are missing; not having (for example) GraphViz installed should not keep
580 the test suite from passing.
582 C<maybe_plan> takes the number of tests to (maybe) run, and a list of
583 modules on which test execution depends:
585 maybe_plan(180, 'SQL::Translator::Parser::MySQL');
587 If one of C<SQL::Translator::Parser::MySQL>'s dependencies does not exist,
588 then the test will be skipped.
590 Instead of a number of tests, you can pass C<undef> if you're using
591 C<done_testing()>, or C<'no_plan'> if you don't want a plan at all.
595 table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok,
602 =item Test the tests!
604 =item Test Count Constants
606 Constants to give the number of tests each C<*_ok> sub uses. e.g. How many tests
607 does C<field_ok> run? Can then use these to set up the test plan easily.
611 As the test subs wrap up lots of tests in one call you can't skip individual
612 tests only whole sets e.g. a whole table or field.
613 We could add C<skip_*> items to the test hashes to allow per test skips. e.g.
615 skip_is_primary_key => "Need to fix primary key parsing.",
617 =item yaml test specs
619 Maybe have the test subs also accept yaml for the test hash ref as it is much
620 nicer for writing big data structures. We can then define tests as in input
621 schema file and test yaml file to compare it against.
627 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
628 Darren Chamberlain <darren@cpan.org>.
630 Thanks to Ken Y. Clark for the original table and field test code taken from
635 perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.