1 package Test::SQL::Translator;
3 # ----------------------------------------------------------------------
4 # Copyright (C) 2003 The SQLFairy Authors
6 # This program is free software; you can redistribute it and/or
7 # modify it under the terms of the GNU General Public License as
8 # published by the Free Software Foundation; version 2.
10 # This program is distributed in the hope that it will be useful, but
11 # WITHOUT ANY WARRANTY; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 # General Public License for more details.
15 # You should have received a copy of the GNU General Public License
16 # along with this program; if not, write to the Free Software
17 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
19 # -------------------------------------------------------------------
25 Test::SQL::Translator - Test::More test functions for the Schema objects.
32 use SQL::Translator::Schema::Constants;
34 use base qw(Exporter);
35 use vars qw($VERSION @EXPORT @EXPORT_OK);
49 # $ATTRIBUTES{ <schema_object_name> } = { <attribname> => <default>, ... }
54 default_value => undef,
60 is_auto_increment => 0,
63 # foreign_key_reference,
78 reference_fields => [],
79 reference_table => '',
99 perform_action_when => undef,
100 database_events => undef,
117 #primary_key => undef, # pkey constraint
121 constraints => undef,
129 procedures => undef, # [] when set
130 tables => undef, # [] when set
131 triggers => undef, # [] when set
132 views => undef, # [] when set
138 # Given a test hash and schema object name set any attribute keys not present in
139 # the test hash to their default value for that schema object type.
140 # e.g. default_attribs( $test, "field" );
141 sub default_attribs {
142 my ($hashref, $object_type) = @_;
144 if ( !exists $ATTRIBUTES{ $object_type } ) {
145 die "Can't add default attribs for unknown Schema "
146 . "object type '$object_type'.";
150 grep { !exists $hashref->{ $_ } }
151 keys %{ $ATTRIBUTES{ $object_type } }
153 $hashref->{ $attr } = $ATTRIBUTES{ $object_type }{ $attr }
159 # Format test name so it will prepend the test names used below.
163 $name = "$name - " if $name;
168 my ($f1,$test,$name) = @_;
169 my $t_name = t_name($name);
170 default_attribs($test,"field");
173 fail " Field '$test->{name}' doesn't exist!";
174 # TODO Do a skip on the following tests. Currently the test counts wont
175 # match at the end. So at least it fails.
179 my $full_name = $f1->table->name.".".$test->{name};
181 is( $f1->name, $test->{name}, "${t_name}Field '$full_name'" );
183 is( $f1->is_valid, $test->{is_valid},
184 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
186 is( $f1->data_type, $test->{data_type},
187 "$t_name type is '$test->{data_type}'" );
189 is( $f1->size, $test->{size}, "$t_name size is '$test->{size}'" );
191 is( $f1->default_value, $test->{default_value},
192 "$t_name default value is "
193 .(defined($test->{default_value}) ? "'$test->{default_value}'" : "UNDEF" )
196 is( $f1->is_nullable, $test->{is_nullable},
197 "$t_name ".($test->{is_nullable} ? 'can' : 'cannot').' be null' );
199 is( $f1->is_unique, $test->{is_unique},
200 "$t_name ".($test->{is_unique} ? 'can' : 'cannot').' be unique' );
202 is( $f1->is_primary_key, $test->{is_primary_key},
203 "$t_name is ".($test->{is_primary_key} ? '' : 'not ').'a primary_key' );
205 is( $f1->is_foreign_key, $test->{is_foreign_key},
206 "$t_name is ".($test->{is_foreign_key} ? '' : 'not').' a foreign_key' );
208 is( $f1->is_auto_increment, $test->{is_auto_increment},
210 .($test->{is_auto_increment} ? '' : 'not ').'an auto_increment' );
212 is( $f1->comments, $test->{comments}, "$t_name comments" );
214 is_deeply( { $f1->extra }, $test->{extra}, "$t_name extra" );
218 my ($obj,$test,$name) = @_;
219 my $t_name = t_name($name);
220 default_attribs($test,"constraint");
222 is( $obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'" );
224 is( $obj->type, $test->{type}, "$t_name type is '$test->{type}'" );
226 is( $obj->deferrable, $test->{deferrable},
227 "$t_name ".($test->{deferrable} ? 'can' : 'cannot').' be deferred' );
229 is( $obj->is_valid, $test->{is_valid},
230 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
232 is($obj->table->name,$test->{table},"$t_name table is '$test->{table}'" );
234 is( $obj->expression, $test->{expression},
235 "$t_name expression is '$test->{expression}'" );
237 is_deeply( [$obj->fields], $test->{fields},
238 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
240 is( $obj->reference_table, $test->{reference_table},
241 "$t_name reference_table is '$test->{reference_table}'" );
243 is_deeply( [$obj->reference_fields], $test->{reference_fields},
244 "$t_name reference_fields are '".join(",",@{$test->{reference_fields}})."'" );
246 is( $obj->match_type, $test->{match_type},
247 "$t_name match_type is '$test->{match_type}'" );
249 is( $obj->on_delete, $test->{on_delete},
250 "$t_name on_delete is '$test->{on_delete}'" );
252 is( $obj->on_update, $test->{on_update},
253 "$t_name on_update is '$test->{on_update}'" );
255 is_deeply( [$obj->options], $test->{options},
256 "$t_name options are '".join(",",@{$test->{options}})."'" );
258 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
262 my ($obj,$test,$name) = @_;
263 my $t_name = t_name($name);
264 default_attribs($test,"index");
266 is( $obj->name, $test->{name}, "${t_name}Index '$test->{name}'" );
268 is( $obj->is_valid, $test->{is_valid},
269 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
271 is( $obj->type, $test->{type}, "$t_name type is '$test->{type}'" );
273 is_deeply( [$obj->fields], $test->{fields},
274 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
276 is_deeply( [$obj->options], $test->{options},
277 "$t_name options are '".join(",",@{$test->{options}})."'" );
279 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
283 my ($obj,$test,$name) = @_;
284 my $t_name = t_name($name);
285 default_attribs($test,"index");
287 is( $obj->name, $test->{name}, "${t_name}Trigger '$test->{name}'" );
289 is( $obj->is_valid, $test->{is_valid},
290 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
292 is( $obj->perform_action_when, $test->{perform_action_when},
293 "$t_name perform_action_when is '$test->{perform_action_when}'" );
295 is( join(',', $obj->database_events), $test->{database_events},
296 sprintf("%s database_events is '%s'",
298 $test->{'database_events'},
302 is( $obj->on_table, $test->{on_table},
303 "$t_name on_table is '$test->{on_table}'" );
305 is( $obj->action, $test->{action}, "$t_name action is '$test->{action}'" );
307 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
311 my ($obj,$test,$name) = @_;
312 my $t_name = t_name($name);
313 default_attribs($test,"index");
315 #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
317 is( $obj->name, $test->{name}, "${t_name}View '$test->{name}'" );
319 is( $obj->is_valid, $test->{is_valid},
320 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
322 is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" );
324 is_deeply( [$obj->fields], $test->{fields},
325 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
327 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
331 my ($obj,$test,$name) = @_;
332 my $t_name = t_name($name);
333 default_attribs($test,"index");
335 #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
337 is( $obj->name, $test->{name}, "${t_name}Procedure '$test->{name}'" );
339 is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" );
341 is_deeply( [$obj->parameters], $test->{parameters},
342 "$t_name parameters are '".join(",",@{$test->{parameters}})."'" );
344 is( $obj->comments, $test->{comments},
345 "$t_name comments is '$test->{comments}'" );
347 is( $obj->owner, $test->{owner}, "$t_name owner is '$test->{owner}'" );
349 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
353 my ($obj,$test,$name) = @_;
354 my $t_name = t_name($name);
355 default_attribs($test,"table");
358 my $tbl_name = $arg{name} || die "Need a table name to test.";
359 is( $obj->{name}, $arg{name}, "${t_name}Table '$arg{name}'" );
361 is_deeply( [$obj->options], $test->{options},
362 "$t_name options are '".join(",",@{$test->{options}})."'" );
364 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
367 if ( $arg{fields} ) {
368 my @fldnames = map {$_->{name}} @{$arg{fields}};
370 [ map {$_->name} $obj->get_fields ],
372 "${t_name} field names are ".join(", ",@fldnames)
374 foreach ( @{$arg{fields}} ) {
375 my $f_name = $_->{name} || die "Need a field name to test.";
376 next unless my $fld = $obj->get_field($f_name);
377 field_ok( $fld, $_, $name );
381 is(scalar($obj->get_fields), undef,
382 "${t_name} has no fields.");
385 # Constraints and Indices
386 _test_kids($obj, $test, $name, {
387 constraint => 'constraints',
393 my ( $obj, $test, $name, $kids ) = @_;
394 my $t_name = t_name($name);
395 my $obj_name = ref $obj;
396 ($obj_name) = $obj_name =~ m/^.*::(.*)$/;
398 while ( my ( $object_type, $plural ) = each %$kids ) {
399 next unless defined $test->{ $plural };
401 if ( my @tests = @{ $test->{ $plural } } ) {
402 my $meth = "get_$plural";
403 my @objects = $obj->$meth;
404 is( scalar(@objects), scalar(@tests),
405 "${t_name}$obj_name has " . scalar(@tests) . " $plural"
408 for my $object (@objects) {
409 my $ans = { lc($obj_name) => $obj->name, %{ shift @tests } };
411 my $meth = "${object_type}_ok";
414 $meth->( $object, $ans, $name );
422 my ($obj,$test,$name) = @_;
423 my $t_name = t_name($name);
424 default_attribs($test,"schema");
426 is( $obj->name, $test->{name}, "${t_name}Schema name is '$test->{name}'" );
428 is( $obj->database, $test->{database},
429 "$t_name database is '$test->{database}'" );
431 is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
433 is( $obj->is_valid, $test->{is_valid},
434 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
437 if ( $test->{tables} ) {
438 is_deeply( [ map {$_->name} $obj->get_tables ],
439 [ map {$_->{name}} @{$test->{tables}} ],
440 "${t_name} table names match" );
441 foreach ( @{$test->{tables}} ) {
442 my $t_name = $_->{name} || die "Need a table name to test.";
443 table_ok( $obj->get_table($t_name), $_, $name );
447 is(scalar($obj->get_tables), undef,
448 "${t_name} has no tables.");
451 # Procedures, Triggers, Views
452 _test_kids($obj, $test, $name, {
453 procedure => 'procedures',
454 trigger => 'triggers',
459 # maybe_plan($ntests, @modules)
461 # Calls plan $ntests if @modules can all be loaded; otherwise,
462 # calls skip_all with an explanation of why the tests were skipped.
464 my ($ntests, @modules) = @_;
467 for my $module (@modules) {
471 if ($@ =~ /Can't locate (\S+)/) {
477 elsif ($@ =~ /([\w\:]+ version [\d\.]+) required.+?this is only version/) {
483 my $msg = sprintf "Missing dependenc%s: %s",
484 @errors == 1 ? 'y' : 'ies',
486 plan skip_all => $msg;
488 elsif ($ntests and $ntests ne 'no_plan') {
489 plan tests => $ntests;
496 1; # compile please ===========================================================
507 use Test::SQL::Translator;
510 my $sqlt = SQL::Translator->new(
512 filename => "$Bin/data/magic/test.magic",
516 my $schema = $sqlt->schema;
518 # Test the table it produced.
519 table_ok( $schema->get_table("Customer"), {
523 name => "CustomerID",
526 default_value => undef,
532 data_type => "VARCHAR",
539 type => "PRIMARY KEY",
540 fields => "CustomerID",
553 Provides a set of Test::More tests for Schema objects. Testing a parsed
554 schema is then as easy as writing a perl data structure describing how you
555 expect the schema to look. Also provides maybe_plan for conditionally running
556 tests based on their dependencies.
558 The data structures given to the test subs don't have to include all the
559 possible values, only the ones you expect to have changed. Any left out will be
560 tested to make sure they are still at their default value. This is a useful
561 check that you your parser hasn't accidentally set schema values you didn't
564 For an example of the output run the t/16xml-parser.t test.
568 All the tests take a first arg of the schema object to test, followed by a
569 hash ref describing how you expect that object to look (you only need give the
570 attributes you expect to have changed from the default).
571 The 3rd arg is an optional test name to pre-pend to all the generated test
588 =head1 CONDITIONAL TESTS
590 The C<maybe_plan> function handles conditionally running an individual
591 test. It is here to enable running the test suite even when dependencies
592 are missing; not having (for example) GraphViz installed should not keep
593 the test suite from passing.
595 C<maybe_plan> takes the number of tests to (maybe) run, and a list of
596 modules on which test execution depends:
598 maybe_plan(180, 'SQL::Translator::Parser::MySQL');
600 If one of C<SQL::Translator::Parser::MySQL>'s dependencies does not exist,
601 then the test will be skipped.
605 table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok,
612 =item Test the tests!
614 =item Test Count Constants
616 Constants to give the number of tests each *_ok sub uses. e.g. How many tests
617 does field_ok run? Can then use these to set up the test plan easily.
621 As the test subs wrap up lots of tests in one call you can't skip idividual
622 tests only whole sets e.g. a whole table or field.
623 We could add skip_* items to the test hashes to allow per test skips. e.g.
625 skip_is_primary_key => "Need to fix primary key parsing.",
627 =item yaml test specs
629 Maybe have the test subs also accept yaml for the test hash ref as its a much
630 nicer for writing big data structures. We can then define tests as in input
631 schema file and test yaml file to compare it against.
639 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
640 Darren Chamberlain <darren@cpan.org>.
642 Thanks to Ken Y. Clark for the original table and field test code taken from
647 perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.