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
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(
+our @EXPORT_OK;
+our $VERSION = '1.59';
+our @EXPORT = qw(
+ schema_ok
table_ok
field_ok
constraint_ok
view_ok
trigger_ok
procedure_ok
+ maybe_plan
);
-# TODO schema_ok
-
-use Test::More;
-use Test::Exception;
-use SQL::Translator::Schema::Constants;
# $ATTRIBUTES{ <schema_object_name> } = { <attribname> => <default>, ... }
-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.
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}'" );
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 {
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 {
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' );
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 {
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 {
is_deeply( [$obj->parameters], $test->{parameters},
"$t_name parameters are '".join(",",@{$test->{parameters}})."'" );
- is( $obj->comments, $test->{comments},
+ is( $obj->comments, $test->{comments},
"$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 {
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 );
}
}
}
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;
+ }
+ return unless defined $ntests;
+
+ if ($ntests ne 'no_plan') {
+ plan tests => $ntests;
+ }
+ else {
+ plan 'no_plan';
+ }
}
1; # compile please ===========================================================
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",
=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
=head2 procedure_ok
+=head1 CONDITIONAL TESTS
+
+The C<maybe_plan> 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<maybe_plan> 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<SQL::Translator::Parser::MySQL>'s dependencies does not exist,
+then the test will be skipped.
+
+Instead of a number of tests, you can pass C<undef> if you're using
+C<done_testing()>, or C<'no_plan'> if you don't want a plan at all.
+
=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
=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
-As the test subs wrap up lots of tests in one call you can't skip idividual
+As the test subs wrap up lots of tests in one call you can't skip individual
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.
=back
-=head1 BUGS
-
=head1 AUTHOR
-Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
+Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
+Darren Chamberlain <darren@cpan.org>.
Thanks to Ken Y. Clark for the original table and field test code taken from
his mysql test.
projects / dbsrgits/SQL-Translator.git / blobdiff