X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest%2FSQL%2FTranslator.pm;h=e69c5a2c33aebe60489502b3c1ff536823ea8ee6;hb=44659089c28216f1984873bc4aa8641e2e0e3410;hp=b2d67e9f057af3f4ef7129abe7acdd79af368404;hpb=9bbbf403746a9dbd316161644f665e055eaf27c1;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/Test/SQL/Translator.pm b/lib/Test/SQL/Translator.pm index b2d67e9..e69c5a2 100644 --- a/lib/Test/SQL/Translator.pm +++ b/lib/Test/SQL/Translator.pm @@ -1,8 +1,6 @@ package Test::SQL::Translator; # ---------------------------------------------------------------------- -# $Id: Translator.pm,v 1.1 2004-02-29 18:26:53 grommit Exp $ -# ---------------------------------------------------------------------- # Copyright (C) 2003 The SQLFairy Authors # # This program is free software; you can redistribute it and/or @@ -30,12 +28,14 @@ Test::SQL::Translator - Test::More test functions for the Schema objects. use strict; use warnings; +use Test::More; +use SQL::Translator::Schema::Constants; use base qw(Exporter); - use vars qw($VERSION @EXPORT @EXPORT_OK); -$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/; -@EXPORT = qw( +$VERSION = '1.59'; +@EXPORT = qw( + schema_ok table_ok field_ok constraint_ok @@ -43,94 +43,117 @@ $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/; view_ok trigger_ok procedure_ok + maybe_plan ); -# TODO schema_ok - -use Test::More; -use Test::Exception; -use SQL::Translator::Schema::Constants; # $ATTRIBUTES{ } = { => , ... } -my %ATTRIBUTES; -$ATTRIBUTES{field} = { - name => undef, - data_type => '', - default_value => undef, - size => '0', - is_primary_key => 0, - is_unique => 0, - is_nullable => 1, - is_foreign_key => 0, - is_auto_increment => 0, - comments => '', - extra => {}, - # foreign_key_reference, - is_valid => 1, - # order -}; -$ATTRIBUTES{constraint} = { - name => '', - type => '', - deferrable => 1, - expression => '', - is_valid => 1, - fields => [], - match_type => '', - options => [], - on_delete => '', - on_update => '', - reference_fields => [], - reference_table => '', -}; -$ATTRIBUTES{'index'} = { - fields => [], - is_valid => 1, - name => "", - options => [], - type => NORMAL, -}; -$ATTRIBUTES{'view'} = { - name => "", - sql => "", - fields => [], -}; -$ATTRIBUTES{'trigger'} = { - name => '', - perform_action_when => undef, - database_event => undef, - on_table => undef, - action => undef, -}; -$ATTRIBUTES{'procedure'} = { - name => '', - sql => '', - parameters => [], - owner => '', - comments => '', -}; -$ATTRIBUTES{table} = { - comments => undef, - name => '', - #primary_key => undef, # pkey constraint - options => [], - #order => 0, - fields => undef, - constraints => undef, - indices => undef, -}; - - +my %ATTRIBUTES = ( + field => { + name => undef, + data_type => '', + default_value => undef, + size => '0', + is_primary_key => 0, + is_unique => 0, + is_nullable => 1, + is_foreign_key => 0, + is_auto_increment => 0, + comments => '', + extra => {}, + # foreign_key_reference, + is_valid => 1, + # order + }, + constraint => { + name => '', + type => '', + deferrable => 1, + expression => '', + is_valid => 1, + fields => [], + match_type => '', + options => [], + on_delete => '', + on_update => '', + reference_fields => [], + reference_table => '', + extra => {}, + }, + index => { + fields => [], + is_valid => 1, + name => "", + options => [], + type => NORMAL, + extra => {}, + }, + view => { + name => "", + sql => "", + fields => [], + is_valid => 1, + extra => {}, + }, + trigger => { + name => '', + perform_action_when => undef, + database_events => undef, + on_table => undef, + action => undef, + is_valid => 1, + extra => {}, + }, + procedure => { + name => '', + sql => '', + parameters => [], + owner => '', + comments => '', + extra => {}, + }, + table => { + comments => undef, + name => '', + #primary_key => undef, # pkey constraint + options => [], + #order => 0, + fields => undef, + constraints => undef, + indices => undef, + is_valid => 1, + extra => {}, + }, + schema => { + name => '', + database => '', + procedures => undef, # [] when set + tables => undef, # [] when set + triggers => undef, # [] when set + views => undef, # [] when set + is_valid => 1, + extra => {}, + } +); # Given a test hash and schema object name set any attribute keys not present in # the test hash to their default value for that schema object type. # e.g. default_attribs( $test, "field" ); sub default_attribs { - my ($foo, $what) = @_; - die "Can't add default attibs - unkown Scheam object type '$what'." - unless exists $ATTRIBUTES{$what}; - $foo->{$_} = $ATTRIBUTES{$what}{$_} - foreach grep !exists($foo->{$_}), keys %{$ATTRIBUTES{$what}}; - return $foo; + my ($hashref, $object_type) = @_; + + if ( !exists $ATTRIBUTES{ $object_type } ) { + die "Can't add default attribs for unknown Schema " + . "object type '$object_type'."; + } + + for my $attr ( + grep { !exists $hashref->{ $_ } } + keys %{ $ATTRIBUTES{ $object_type } } + ) { + $hashref->{ $attr } = $ATTRIBUTES{ $object_type }{ $attr } + } + + return $hashref; } # Format test name so it will prepend the test names used below. @@ -148,13 +171,17 @@ sub field_ok { unless ($f1) { fail " Field '$test->{name}' doesn't exist!"; + # TODO Do a skip on the following tests. Currently the test counts wont + # match at the end. So at least it fails. return; } - is( $f1->name, $test->{name}, "${t_name}Field name '$test->{name}'" ); + my $full_name = $f1->table->name.".".$test->{name}; + + is( $f1->name, $test->{name}, "${t_name}Field '$full_name'" ); is( $f1->is_valid, $test->{is_valid}, - "$t_name is".($test->{is_valid} ? '' : 'not ').'valid' ); + "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' ); is( $f1->data_type, $test->{data_type}, "$t_name type is '$test->{data_type}'" ); @@ -227,6 +254,8 @@ sub constraint_ok { is_deeply( [$obj->options], $test->{options}, "$t_name options are '".join(",",@{$test->{options}})."'" ); + + is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" ); } sub index_ok { @@ -246,6 +275,8 @@ sub index_ok { is_deeply( [$obj->options], $test->{options}, "$t_name options are '".join(",",@{$test->{options}})."'" ); + + is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" ); } sub trigger_ok { @@ -253,7 +284,7 @@ sub trigger_ok { my $t_name = t_name($name); default_attribs($test,"index"); - is( $obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'" ); + is( $obj->name, $test->{name}, "${t_name}Trigger '$test->{name}'" ); is( $obj->is_valid, $test->{is_valid}, "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' ); @@ -261,13 +292,19 @@ sub trigger_ok { is( $obj->perform_action_when, $test->{perform_action_when}, "$t_name perform_action_when is '$test->{perform_action_when}'" ); - is( $obj->database_event, $test->{database_event}, - "$t_name database_event is '$test->{database_event}'" ); + is( join(',', $obj->database_events), $test->{database_events}, + sprintf("%s database_events is '%s'", + $t_name, + $test->{'database_events'}, + ) + ); is( $obj->on_table, $test->{on_table}, "$t_name on_table is '$test->{on_table}'" ); is( $obj->action, $test->{action}, "$t_name action is '$test->{action}'" ); + + is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" ); } sub view_ok { @@ -286,6 +323,8 @@ sub view_ok { is_deeply( [$obj->fields], $test->{fields}, "$t_name fields are '".join(",",@{$test->{fields}})."'" ); + + is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" ); } sub procedure_ok { @@ -306,6 +345,8 @@ sub procedure_ok { "$t_name comments is '$test->{comments}'" ); is( $obj->owner, $test->{owner}, "$t_name owner is '$test->{owner}'" ); + + is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" ); } sub table_ok { @@ -315,44 +356,62 @@ sub table_ok { my %arg = %$test; my $tbl_name = $arg{name} || die "Need a table name to test."; - is( $obj->{name}, $arg{name}, "${t_name}Table name '$arg{name}'" ); + is( $obj->{name}, $arg{name}, "${t_name}Table '$arg{name}'" ); is_deeply( [$obj->options], $test->{options}, "$t_name options are '".join(",",@{$test->{options}})."'" ); + is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" ); + # Fields if ( $arg{fields} ) { - my @fldnames = map { $_->{name} } @{$arg{fields}}; - is_deeply( [ map {$_->name} $obj->get_fields ], - [ map {$_->{name}} @{$arg{fields}} ], - "${t_name}Table $tbl_name fields match" ); + my @fldnames = map {$_->{name}} @{$arg{fields}}; + is_deeply( + [ map {$_->name} $obj->get_fields ], + [ @fldnames ], + "${t_name} field names are ".join(", ",@fldnames) + ); foreach ( @{$arg{fields}} ) { my $f_name = $_->{name} || die "Need a field name to test."; - field_ok( $obj->get_field($f_name), $_, $name ); + next unless my $fld = $obj->get_field($f_name); + field_ok( $fld, $_, $name ); } } else { is(scalar($obj->get_fields), undef, - "${t_name}Table $tbl_name has no fields."); + "${t_name} has no fields."); } - # Constraints and indices - my %bits = ( - constraint => "constraints", - 'index' => "indices", - ); - while ( my($foo,$plural) = each %bits ) { - next unless defined $arg{$plural}; - if ( my @tfoo = @{$arg{$plural}} ) { + # Constraints and Indices + _test_kids($obj, $test, $name, { + constraint => 'constraints', + index => 'indices', + }); +} + +sub _test_kids { + my ( $obj, $test, $name, $kids ) = @_; + my $t_name = t_name($name); + my $obj_name = ref $obj; + ($obj_name) = $obj_name =~ m/^.*::(.*)$/; + + while ( my ( $object_type, $plural ) = each %$kids ) { + next unless defined $test->{ $plural }; + + if ( my @tests = @{ $test->{ $plural } } ) { my $meth = "get_$plural"; - my @foo = $obj->$meth; - is(scalar(@foo), scalar(@tfoo), - "${t_name}Table $tbl_name has ".scalar(@tfoo)." $plural"); - foreach ( @foo ) { - my $ans = { table => $obj->name, %{shift @tfoo}}; - my $meth = "${foo}_ok"; - { no strict 'refs'; - $meth->( $_, $ans, $name ); + my @objects = $obj->$meth; + is( scalar(@objects), scalar(@tests), + "${t_name}$obj_name has " . scalar(@tests) . " $plural" + ); + + for my $object (@objects) { + my $ans = { lc($obj_name) => $obj->name, %{ shift @tests } }; + + my $meth = "${object_type}_ok"; + { + no strict 'refs'; + $meth->( $object, $ans, $name ); } } } @@ -363,6 +422,75 @@ sub schema_ok { my ($obj,$test,$name) = @_; my $t_name = t_name($name); default_attribs($test,"schema"); + + is( $obj->name, $test->{name}, "${t_name}Schema name is '$test->{name}'" ); + + is( $obj->database, $test->{database}, + "$t_name database is '$test->{database}'" ); + + is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" ); + + is( $obj->is_valid, $test->{is_valid}, + "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' ); + + # Tables + if ( $test->{tables} ) { + is_deeply( [ map {$_->name} $obj->get_tables ], + [ map {$_->{name}} @{$test->{tables}} ], + "${t_name} table names match" ); + foreach ( @{$test->{tables}} ) { + my $t_name = $_->{name} || die "Need a table name to test."; + table_ok( $obj->get_table($t_name), $_, $name ); + } + } + else { + is(scalar($obj->get_tables), undef, + "${t_name} has no tables."); + } + + # Procedures, Triggers, Views + _test_kids($obj, $test, $name, { + procedure => 'procedures', + trigger => 'triggers', + view => 'views', + }); +} + +# maybe_plan($ntests, @modules) +# +# Calls plan $ntests if @modules can all be loaded; otherwise, +# calls skip_all with an explanation of why the tests were skipped. +sub maybe_plan { + my ($ntests, @modules) = @_; + my @errors; + + for my $module (@modules) { + eval "use $module;"; + next if !$@; + + if ($@ =~ /Can't locate (\S+)/) { + my $mod = $1; + $mod =~ s/\.pm$//; + $mod =~ s#/#::#g; + push @errors, $mod; + } + elsif ($@ =~ /([\w\:]+ version [\d\.]+) required.+?this is only version/) { + push @errors, $1; + } + } + + if (@errors) { + my $msg = sprintf "Missing dependenc%s: %s", + @errors == 1 ? 'y' : 'ies', + join ", ", @errors; + plan skip_all => $msg; + } + elsif ($ntests and $ntests ne 'no_plan') { + plan tests => $ntests; + } + else { + plan 'no_plan'; + } } 1; # compile please =========================================================== @@ -382,11 +510,11 @@ __END__ my $sqlt = SQL::Translator->new( parser => "Magic", filename => "$Bin/data/magic/test.magic", - ... + ... ); ... my $schema = $sqlt->schema; - + # Test the table it produced. table_ok( $schema->get_table("Customer"), { name => "Customer", @@ -422,24 +550,25 @@ __END__ =head1 DESCSIPTION -Provides a set of Test::More tests for Schema objects. Tesing a parsed +Provides a set of Test::More tests for Schema objects. Testing a parsed schema is then as easy as writing a perl data structure describing how you -expect the schema to look. +expect the schema to look. Also provides maybe_plan for conditionally running +tests based on their dependencies. -The data structures given to the test subs don't have to include all the +The data structures given to the test subs don't have to include all the possible values, only the ones you expect to have changed. Any left out will be -tested to make sure they are still at their default value. This is a usefull +tested to make sure they are still at their default value. This is a useful check that you your parser hasn't accidentally set schema values you didn't -expect it to. (And makes tests look nice and long ;-) +expect it to. For an example of the output run the t/16xml-parser.t test. =head1 Tests -All the tests take a first arg of the schema object to test, followed by a +All the tests take a first arg of the schema object to test, followed by a hash ref describing how you expect that object to look (you only need give the attributes you expect to have changed from the default). -The 3rd arg is an optional test name to pre-pend to all the generated test +The 3rd arg is an optional test name to pre-pend to all the generated test names. =head2 table_ok @@ -456,9 +585,25 @@ names. =head2 procedure_ok +=head1 CONDITIONAL TESTS + +The C function handles conditionally running an individual +test. It is here to enable running the test suite even when dependencies +are missing; not having (for example) GraphViz installed should not keep +the test suite from passing. + +C takes the number of tests to (maybe) run, and a list of +modules on which test execution depends: + + maybe_plan(180, 'SQL::Translator::Parser::MySQL'); + +If one of C's dependencies does not exist, +then the test will be skipped. + =head1 EXPORTS -table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok +table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok, +maybe_plan =head1 TODO @@ -466,9 +611,10 @@ table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok =item Test the tests! -=item schema_ok() +=item Test Count Constants -Test whole schema. +Constants to give the number of tests each *_ok sub uses. e.g. How many tests +does field_ok run? Can then use these to set up the test plan easily. =item Test skipping @@ -490,7 +636,8 @@ schema file and test yaml file to compare it against. =head1 AUTHOR -Mark D. Addison Emark.addison@itn.co.ukE. +Mark D. Addison Emark.addison@itn.co.ukE, +Darren Chamberlain . Thanks to Ken Y. Clark for the original table and field test code taken from his mysql test.