package Test::SQL::Translator;
-# ----------------------------------------------------------------------
-# $Id: Translator.pm,v 1.5 2004-03-05 12:12:33 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.5 $ =~ /(\d+)\.(\d+)/;
-@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 => '',
-};
-$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.
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 {
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(
+ 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 );
}
}
}
}
}
-
-
sub schema_ok {
my ($obj,$test,$name) = @_;
my $t_name = t_name($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' );
# 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 {
+ elsif ($ntests and $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
=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
=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