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/) {
465 my $msg = sprintf "Missing dependenc%s: %s",
466 @errors == 1 ? 'y' : 'ies',
468 plan skip_all => $msg;
470 return unless defined $ntests;
472 if ($ntests ne 'no_plan') {
473 plan tests => $ntests;
480 1; # compile please ===========================================================
491 use Test::SQL::Translator;
494 my $sqlt = SQL::Translator->new(
496 filename => "$Bin/data/magic/test.magic",
500 my $schema = $sqlt->schema;
502 # Test the table it produced.
503 table_ok( $schema->get_table("Customer"), {
507 name => "CustomerID",
510 default_value => undef,
516 data_type => "VARCHAR",
523 type => "PRIMARY KEY",
524 fields => "CustomerID",
537 Provides a set of Test::More tests for Schema objects. Testing a parsed
538 schema is then as easy as writing a perl data structure describing how you
539 expect the schema to look. Also provides C<maybe_plan> for conditionally running
540 tests based on their dependencies.
542 The data structures given to the test subs don't have to include all the
543 possible values, only the ones you expect to have changed. Any left out will be
544 tested to make sure they are still at their default value. This is a useful
545 check that you your parser hasn't accidentally set schema values you didn't
548 For an example of the output run the F<t/16xml-parser.t> test.
552 All the tests take a first arg of the schema object to test, followed by a
553 hash ref describing how you expect that object to look (you only need give the
554 attributes you expect to have changed from the default).
555 The 3rd arg is an optional test name to prepend to all the generated test
572 =head1 CONDITIONAL TESTS
574 The C<maybe_plan> function handles conditionally running an individual
575 test. It is here to enable running the test suite even when dependencies
576 are missing; not having (for example) GraphViz installed should not keep
577 the test suite from passing.
579 C<maybe_plan> takes the number of tests to (maybe) run, and a list of
580 modules on which test execution depends:
582 maybe_plan(180, 'SQL::Translator::Parser::MySQL');
584 If one of C<SQL::Translator::Parser::MySQL>'s dependencies does not exist,
585 then the test will be skipped.
587 Instead of a number of tests, you can pass C<undef> if you're using
588 C<done_testing()>, or C<'no_plan'> if you don't want a plan at all.
592 table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok,
599 =item Test the tests!
601 =item Test Count Constants
603 Constants to give the number of tests each C<*_ok> sub uses. e.g. How many tests
604 does C<field_ok> run? Can then use these to set up the test plan easily.
608 As the test subs wrap up lots of tests in one call you can't skip individual
609 tests only whole sets e.g. a whole table or field.
610 We could add C<skip_*> items to the test hashes to allow per test skips. e.g.
612 skip_is_primary_key => "Need to fix primary key parsing.",
614 =item yaml test specs
616 Maybe have the test subs also accept yaml for the test hash ref as it is much
617 nicer for writing big data structures. We can then define tests as in input
618 schema file and test yaml file to compare it against.
624 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
625 Darren Chamberlain <darren@cpan.org>.
627 Thanks to Ken Y. Clark for the original table and field test code taken from
632 perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.