package Test::SQL::Translator;
-# ----------------------------------------------------------------------
-# 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 = '1.59';
-@EXPORT = qw(
+our @EXPORT_OK;
+our $VERSION = '1.59';
+our @EXPORT = qw(
schema_ok
table_ok
field_ok
maybe_plan
);
-use Test::More;
-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 => '',
- extra => {},
-};
-$ATTRIBUTES{'index'} = {
- fields => [],
- is_valid => 1,
- name => "",
- options => [],
- type => NORMAL,
- extra => {},
-};
-$ATTRIBUTES{'view'} = {
- name => "",
- sql => "",
- fields => [],
- is_valid => 1,
- extra => {},
-};
-$ATTRIBUTES{'trigger'} = {
- name => '',
- perform_action_when => undef,
- database_event => undef,
- on_table => undef,
- action => undef,
- is_valid => 1,
- extra => {},
-};
-$ATTRIBUTES{'procedure'} = {
- name => '',
- sql => '',
- parameters => [],
- owner => '',
- comments => '',
- extra => {},
-};
-$ATTRIBUTES{table} = {
- comments => undef,
- name => '',
- #primary_key => undef, # pkey constraint
- options => [],
- #order => 0,
- fields => undef,
- constraints => undef,
- indices => undef,
- is_valid => 1,
- extra => {},
-};
-$ATTRIBUTES{schema} = {
- name => '',
- database => '',
- procedures => undef, # [] when set
- tables => undef, # [] when set
- triggers => undef, # [] when set
- views => undef, # [] when set
- is_valid => 1,
- extra => {},
-};
-
-
+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.
is_deeply( [$obj->options], $test->{options},
"$t_name options are '".join(",",@{$test->{options}})."'" );
-
+
is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
}
is_deeply( [$obj->options], $test->{options},
"$t_name options are '".join(",",@{$test->{options}})."'" );
-
+
is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
}
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" );
}
is_deeply( [$obj->fields], $test->{fields},
"$t_name fields are '".join(",",@{$test->{fields}})."'" );
-
+
is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
}
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" );
}
# Fields
if ( $arg{fields} ) {
my @fldnames = map {$_->{name}} @{$arg{fields}};
- is_deeply(
+ is_deeply(
[ map {$_->name} $obj->get_fields ],
[ @fldnames ],
"${t_name} field names are ".join(", ",@fldnames)
# 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 );
}
}
}
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},
# Procedures, Triggers, Views
_test_kids($obj, $test, $name, {
- procedure => "procedures",
- trigger => "triggers",
- view => "views",
+ procedure => 'procedures',
+ trigger => 'triggers',
+ view => 'views',
});
}
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) {
join ", ", @errors;
plan skip_all => $msg;
}
- else {
+ return unless defined $ntests;
+
+ if ($ntests ne 'no_plan') {
plan tests => $ntests;
}
+ else {
+ plan 'no_plan';
+ }
}
1; # compile please ===========================================================
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.
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,
=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>, Darren Chamberlain <darren@cpan.org>.
+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.