From: Mark Addison Date: Sun, 29 Feb 2004 18:26:53 +0000 (+0000) Subject: Test::More Schema testing. X-Git-Tag: v0.06~168 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9bbbf403746a9dbd316161644f665e055eaf27c1;p=dbsrgits%2FSQL-Translator.git Test::More Schema testing. --- diff --git a/lib/Test/SQL/Translator.pm b/lib/Test/SQL/Translator.pm new file mode 100644 index 0000000..b2d67e9 --- /dev/null +++ b/lib/Test/SQL/Translator.pm @@ -0,0 +1,502 @@ +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 +# modify it under the terms of the GNU General Public License as +# published by the Free Software Foundation; version 2. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +# 02111-1307 USA +# ------------------------------------------------------------------- + +=pod + +=head1 NAME + +Test::SQL::Translator - Test::More test functions for the Schema objects. + +=cut + +use strict; +use warnings; + +use base qw(Exporter); + +use vars qw($VERSION @EXPORT @EXPORT_OK); +$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/; +@EXPORT = qw( + table_ok + field_ok + constraint_ok + index_ok + view_ok + trigger_ok + procedure_ok +); +# 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, +}; + + + +# 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; +} + +# Format test name so it will prepend the test names used below. +sub t_name { + my $name = shift; + $name ||= ""; + $name = "$name - " if $name; + return $name; +} + +sub field_ok { + my ($f1,$test,$name) = @_; + my $t_name = t_name($name); + default_attribs($test,"field"); + + unless ($f1) { + fail " Field '$test->{name}' doesn't exist!"; + return; + } + + is( $f1->name, $test->{name}, "${t_name}Field name '$test->{name}'" ); + + is( $f1->is_valid, $test->{is_valid}, + "$t_name is".($test->{is_valid} ? '' : 'not ').'valid' ); + + is( $f1->data_type, $test->{data_type}, + "$t_name type is '$test->{data_type}'" ); + + is( $f1->size, $test->{size}, "$t_name size is '$test->{size}'" ); + + is( $f1->default_value, $test->{default_value}, + "$t_name default value is " + .(defined($test->{default_value}) ? "'$test->{default_value}'" : "UNDEF" ) + ); + + is( $f1->is_nullable, $test->{is_nullable}, + "$t_name ".($test->{is_nullable} ? 'can' : 'cannot').' be null' ); + + is( $f1->is_unique, $test->{is_unique}, + "$t_name ".($test->{is_unique} ? 'can' : 'cannot').' be unique' ); + + is( $f1->is_primary_key, $test->{is_primary_key}, + "$t_name is ".($test->{is_primary_key} ? '' : 'not ').'a primary_key' ); + + is( $f1->is_foreign_key, $test->{is_foreign_key}, + "$t_name is ".($test->{is_foreign_key} ? '' : 'not').' a foreign_key' ); + + is( $f1->is_auto_increment, $test->{is_auto_increment}, + "$t_name is " + .($test->{is_auto_increment} ? '' : 'not ').'an auto_increment' ); + + is( $f1->comments, $test->{comments}, "$t_name comments" ); + + is_deeply( { $f1->extra }, $test->{extra}, "$t_name extra" ); +} + +sub constraint_ok { + my ($obj,$test,$name) = @_; + my $t_name = t_name($name); + default_attribs($test,"constraint"); + + is( $obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'" ); + + is( $obj->type, $test->{type}, "$t_name type is '$test->{type}'" ); + + is( $obj->deferrable, $test->{deferrable}, + "$t_name ".($test->{deferrable} ? 'can' : 'cannot').' be deferred' ); + + is( $obj->is_valid, $test->{is_valid}, + "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' ); + + is($obj->table->name,$test->{table},"$t_name table is '$test->{table}'" ); + + is( $obj->expression, $test->{expression}, + "$t_name expression is '$test->{expression}'" ); + + is_deeply( [$obj->fields], $test->{fields}, + "$t_name fields are '".join(",",@{$test->{fields}})."'" ); + + is( $obj->reference_table, $test->{reference_table}, + "$t_name reference_table is '$test->{reference_table}'" ); + + is_deeply( [$obj->reference_fields], $test->{reference_fields}, + "$t_name reference_fields are '".join(",",@{$test->{reference_fields}})."'" ); + + is( $obj->match_type, $test->{match_type}, + "$t_name match_type is '$test->{match_type}'" ); + + is( $obj->on_delete, $test->{on_delete}, + "$t_name on_delete is '$test->{on_delete}'" ); + + is( $obj->on_update, $test->{on_update}, + "$t_name on_update is '$test->{on_update}'" ); + + is_deeply( [$obj->options], $test->{options}, + "$t_name options are '".join(",",@{$test->{options}})."'" ); +} + +sub index_ok { + my ($obj,$test,$name) = @_; + my $t_name = t_name($name); + default_attribs($test,"index"); + + is( $obj->name, $test->{name}, "${t_name}Index '$test->{name}'" ); + + is( $obj->is_valid, $test->{is_valid}, + "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' ); + + is( $obj->type, $test->{type}, "$t_name type is '$test->{type}'" ); + + is_deeply( [$obj->fields], $test->{fields}, + "$t_name fields are '".join(",",@{$test->{fields}})."'" ); + + is_deeply( [$obj->options], $test->{options}, + "$t_name options are '".join(",",@{$test->{options}})."'" ); +} + +sub trigger_ok { + my ($obj,$test,$name) = @_; + my $t_name = t_name($name); + default_attribs($test,"index"); + + is( $obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'" ); + + is( $obj->is_valid, $test->{is_valid}, + "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' ); + + 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( $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}'" ); +} + +sub view_ok { + my ($obj,$test,$name) = @_; + my $t_name = t_name($name); + default_attribs($test,"index"); + + #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' ); + + is( $obj->name, $test->{name}, "${t_name}View '$test->{name}'" ); + + is( $obj->is_valid, $test->{is_valid}, + "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' ); + + is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" ); + + is_deeply( [$obj->fields], $test->{fields}, + "$t_name fields are '".join(",",@{$test->{fields}})."'" ); +} + +sub procedure_ok { + my ($obj,$test,$name) = @_; + my $t_name = t_name($name); + default_attribs($test,"index"); + + #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' ); + + is( $obj->name, $test->{name}, "${t_name}Procedure '$test->{name}'" ); + + is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" ); + + is_deeply( [$obj->parameters], $test->{parameters}, + "$t_name parameters are '".join(",",@{$test->{parameters}})."'" ); + + is( $obj->comments, $test->{comments}, + "$t_name comments is '$test->{comments}'" ); + + is( $obj->owner, $test->{owner}, "$t_name owner is '$test->{owner}'" ); +} + +sub table_ok { + my ($obj,$test,$name) = @_; + my $t_name = t_name($name); + default_attribs($test,"table"); + 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_deeply( [$obj->options], $test->{options}, + "$t_name options are '".join(",",@{$test->{options}})."'" ); + + # 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" ); + foreach ( @{$arg{fields}} ) { + my $f_name = $_->{name} || die "Need a field name to test."; + field_ok( $obj->get_field($f_name), $_, $name ); + } + } + else { + is(scalar($obj->get_fields), undef, + "${t_name}Table $tbl_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}} ) { + 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 ); + } + } + } + } +} + +sub schema_ok { + my ($obj,$test,$name) = @_; + my $t_name = t_name($name); + default_attribs($test,"schema"); +} + +1; # compile please =========================================================== +__END__ + +=pod + +=head1 SYNOPSIS + + # t/magic.t + + use FindBin '$Bin'; + use Test::More; + use Test::SQL::Translator; + + # Run parse + 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", + fields => [ + { + name => "CustomerID", + data_type => "INT", + size => 12, + default_value => undef, + is_nullable => 0, + is_primary_key => 1, + }, + { + name => "bar", + data_type => "VARCHAR", + size => 255, + is_nullable => 0, + }, + ], + constraints => [ + { + type => "PRIMARY KEY", + fields => "CustomerID", + }, + ], + indices => [ + { + name => "barindex", + fields => ["bar"], + }, + ], + }); + +=head1 DESCSIPTION + +Provides a set of Test::More tests for Schema objects. Tesing a parsed +schema is then as easy as writing a perl data structure describing how you +expect the schema to look. + +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 +check that you your parser hasn't accidentally set schema values you didn't +expect it to. (And makes tests look nice and long ;-) + +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 +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 +names. + +=head2 table_ok + +=head2 field_ok + +=head2 constraint_ok + +=head2 index_ok + +=head2 view_ok + +=head2 trigger_ok + +=head2 procedure_ok + +=head1 EXPORTS + +table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok + +=head1 TODO + +=over 4 + +=item Test the tests! + +=item schema_ok() + +Test whole schema. + +=item Test skipping + +As the test subs wrap up lots of tests in one call you can't skip idividual +tests only whole sets e.g. a whole table or field. +We could add skip_* items to the test hashes to allow per test skips. e.g. + + skip_is_primary_key => "Need to fix primary key parsing.", + +=item yaml test specs + +Maybe have the test subs also accept yaml for the test hash ref as its a much +nicer for writing big data structures. We can then define tests as in input +schema file and test yaml file to compare it against. + +=back + +=head1 BUGS + +=head1 AUTHOR + +Mark D. Addison Emark.addison@itn.co.ukE. + +Thanks to Ken Y. Clark for the original table and field test code taken from +his mysql test. + +=head1 SEE ALSO + +perl(1), SQL::Translator, SQL::Translator::Schema, Test::More. + +=cut