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) {
469 if ($@ && $@ =~ /Can't locate (\S+)/) {
478 my $msg = sprintf "Missing dependenc%s: %s",
479 @errors == 1 ? 'y' : 'ies',
481 plan skip_all => $msg;
484 plan tests => $ntests;
488 1; # compile please ===========================================================
499 use Test::SQL::Translator;
502 my $sqlt = SQL::Translator->new(
504 filename => "$Bin/data/magic/test.magic",
508 my $schema = $sqlt->schema;
510 # Test the table it produced.
511 table_ok( $schema->get_table("Customer"), {
515 name => "CustomerID",
518 default_value => undef,
524 data_type => "VARCHAR",
531 type => "PRIMARY KEY",
532 fields => "CustomerID",
545 Provides a set of Test::More tests for Schema objects. Testing a parsed
546 schema is then as easy as writing a perl data structure describing how you
547 expect the schema to look. Also provides maybe_plan for conditionally running
548 tests based on their dependencies.
550 The data structures given to the test subs don't have to include all the
551 possible values, only the ones you expect to have changed. Any left out will be
552 tested to make sure they are still at their default value. This is a usefull
553 check that you your parser hasn't accidentally set schema values you didn't
556 For an example of the output run the t/16xml-parser.t test.
560 All the tests take a first arg of the schema object to test, followed by a
561 hash ref describing how you expect that object to look (you only need give the
562 attributes you expect to have changed from the default).
563 The 3rd arg is an optional test name to pre-pend to all the generated test
580 =head1 CONDITIONAL TESTS
582 The C<maybe_plan> function handles conditionally running an individual
583 test. It is here to enable running the test suite even when dependencies
584 are missing; not having (for example) GraphViz installed should not keep
585 the test suite from passing.
587 C<maybe_plan> takes the number of tests to (maybe) run, and a list of
588 modules on which test execution depends:
590 maybe_plan(180, 'SQL::Translator::Parser::MySQL');
592 If one of C<SQL::Translator::Parser::MySQL>'s dependencies does not exist,
593 then the test will be skipped.
597 table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok,
604 =item Test the tests!
606 =item Test Count Constants
608 Constants to give the number of tests each *_ok sub uses. e.g. How many tests
609 does field_ok run? Can then use these to set up the test plan easily.
613 As the test subs wrap up lots of tests in one call you can't skip idividual
614 tests only whole sets e.g. a whole table or field.
615 We could add skip_* items to the test hashes to allow per test skips. e.g.
617 skip_is_primary_key => "Need to fix primary key parsing.",
619 =item yaml test specs
621 Maybe have the test subs also accept yaml for the test hash ref as its a much
622 nicer for writing big data structures. We can then define tests as in input
623 schema file and test yaml file to compare it against.
631 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
632 Darren Chamberlain <darren@cpan.org>.
634 Thanks to Ken Y. Clark for the original table and field test code taken from
639 perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.