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 elsif ($ntests and $ntests ne 'no_plan') {
471 plan tests => $ntests;
478 1; # compile please ===========================================================
489 use Test::SQL::Translator;
492 my $sqlt = SQL::Translator->new(
494 filename => "$Bin/data/magic/test.magic",
498 my $schema = $sqlt->schema;
500 # Test the table it produced.
501 table_ok( $schema->get_table("Customer"), {
505 name => "CustomerID",
508 default_value => undef,
514 data_type => "VARCHAR",
521 type => "PRIMARY KEY",
522 fields => "CustomerID",
535 Provides a set of Test::More tests for Schema objects. Testing a parsed
536 schema is then as easy as writing a perl data structure describing how you
537 expect the schema to look. Also provides maybe_plan for conditionally running
538 tests based on their dependencies.
540 The data structures given to the test subs don't have to include all the
541 possible values, only the ones you expect to have changed. Any left out will be
542 tested to make sure they are still at their default value. This is a useful
543 check that you your parser hasn't accidentally set schema values you didn't
546 For an example of the output run the t/16xml-parser.t test.
550 All the tests take a first arg of the schema object to test, followed by a
551 hash ref describing how you expect that object to look (you only need give the
552 attributes you expect to have changed from the default).
553 The 3rd arg is an optional test name to pre-pend to all the generated test
570 =head1 CONDITIONAL TESTS
572 The C<maybe_plan> function handles conditionally running an individual
573 test. It is here to enable running the test suite even when dependencies
574 are missing; not having (for example) GraphViz installed should not keep
575 the test suite from passing.
577 C<maybe_plan> takes the number of tests to (maybe) run, and a list of
578 modules on which test execution depends:
580 maybe_plan(180, 'SQL::Translator::Parser::MySQL');
582 If one of C<SQL::Translator::Parser::MySQL>'s dependencies does not exist,
583 then the test will be skipped.
587 table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok,
594 =item Test the tests!
596 =item Test Count Constants
598 Constants to give the number of tests each *_ok sub uses. e.g. How many tests
599 does field_ok run? Can then use these to set up the test plan easily.
603 As the test subs wrap up lots of tests in one call you can't skip individual
604 tests only whole sets e.g. a whole table or field.
605 We could add skip_* items to the test hashes to allow per test skips. e.g.
607 skip_is_primary_key => "Need to fix primary key parsing.",
609 =item yaml test specs
611 Maybe have the test subs also accept yaml for the test hash ref as its a much
612 nicer for writing big data structures. We can then define tests as in input
613 schema file and test yaml file to compare it against.
621 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
622 Darren Chamberlain <darren@cpan.org>.
624 Thanks to Ken Y. Clark for the original table and field test code taken from
629 perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.