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=2f4b040d6ae14a152348ede8cf3c2eb6e2e12b76;hpb=49133ae73acfa89f849086f5c28fc9395cd2bebe;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/Test/SQL/Translator.pm b/lib/Test/SQL/Translator.pm index 2f4b040..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.4 2004-03-04 14:41:49 dlc Exp $ -# ---------------------------------------------------------------------- # Copyright (C) 2003 The SQLFairy Authors # # This program is free software; you can redistribute it and/or @@ -30,12 +28,13 @@ 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.4 $ =~ /(\d+)\.(\d+)/; -@EXPORT = qw( +$VERSION = '1.59'; +@EXPORT = qw( schema_ok table_ok field_ok @@ -47,103 +46,114 @@ $VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/; maybe_plan ); -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 => [], - is_valid => 1, -}; -$ATTRIBUTES{'trigger'} = { - name => '', - perform_action_when => undef, - database_event => undef, - on_table => undef, - action => undef, - is_valid => 1, -}; -$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, - is_valid => 1, -}; -$ATTRIBUTES{schema} = { - name => '', - database => '', - procedures => undef, # [] when set - tables => undef, # [] when set - triggers => undef, # [] when set - views => undef, # [] when set - is_valid => 1, -}; - - +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. @@ -244,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 { @@ -263,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 { @@ -270,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' ); @@ -278,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 { @@ -303,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 { @@ -323,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 { @@ -337,6 +361,8 @@ sub table_ok { 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}}; @@ -358,38 +384,40 @@ sub table_ok { # Constraints and Indices _test_kids($obj, $test, $name, { - constraint => "constraints", - 'index' => "indices", + constraint => 'constraints', + index => 'indices', }); } sub _test_kids { - my ($obj, $test, $name, $kids) = @_; - my $t_name = t_name($name); + my ( $obj, $test, $name, $kids ) = @_; + my $t_name = t_name($name); my $obj_name = ref $obj; ($obj_name) = $obj_name =~ m/^.*::(.*)$/; - while ( my($foo,$plural) = each %$kids ) { - next unless defined $test->{$plural}; - if ( my @tfoo = @{$test->{$plural}} ) { + 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}$obj_name has ".scalar(@tfoo)." $plural"); - foreach ( @foo ) { - my $ans = { lc($obj_name) => $obj->name, %{shift @tfoo}}; - #my $ans = 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 ); } } } } } - - sub schema_ok { my ($obj,$test,$name) = @_; my $t_name = t_name($name); @@ -399,6 +427,8 @@ sub schema_ok { 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' ); @@ -420,9 +450,9 @@ sub schema_ok { # Procedures, Triggers, Views _test_kids($obj, $test, $name, { - procedure => "procedures", - trigger => "triggers", - view => "views", + procedure => 'procedures', + trigger => 'triggers', + view => 'views', }); } @@ -436,12 +466,17 @@ sub maybe_plan { for my $module (@modules) { eval "use $module;"; - if ($@ && $@ =~ /Can't locate (\S+)/) { + 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) { @@ -450,9 +485,12 @@ sub maybe_plan { join ", ", @errors; plan skip_all => $msg; } - else { + elsif ($ntests and $ntests ne 'no_plan') { plan tests => $ntests; } + else { + plan 'no_plan'; + } } 1; # compile please =========================================================== @@ -472,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", @@ -512,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 @@ -572,13 +611,9 @@ maybe_plan =item Test the tests! -=item schema_ok() - -Test whole schema. - =item Test Count Constants -Constants to give the number of tests each *_ok sub uses. e.g. How many tests +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 @@ -601,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.