[dbsrgits/SQL-Translator.git] / lib / Test / SQL / Translator.pm

package Test::SQL::Translator;

# ----------------------------------------------------------------------
# $Id: Translator.pm,v 1.6 2004-07-08 17:29:56 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.6 $ =~ /(\d+)\.(\d+)/;
@EXPORT = qw(
    schema_ok
    table_ok
    field_ok
    constraint_ok
    index_ok
    view_ok
    trigger_ok
    procedure_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,
};


# 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!";
        # TODO Do a skip on the following tests. Currently the test counts wont
        # match at the end. So at least it fails.
        return;
    }

    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' );

    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 '$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 ],
            [ @fldnames ],
            "${t_name}    field names are ".join(", ",@fldnames)
        );
        foreach ( @{$arg{fields}} ) {
            my $f_name = $_->{name} || die "Need a field name to test.";
            next unless my $fld = $obj->get_field($f_name);
            field_ok( $fld, $_, $name );
        }
    }
    else {
        is(scalar($obj->get_fields), undef,
            "${t_name}    has no fields.");
    }

    # 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($foo,$plural) = each %$kids ) {
        next unless defined $test->{$plural};
        if ( my @tfoo = @{$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  );
                }
            }
        }
    }
}

sub schema_ok {
    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( $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;";
        if ($@ && $@ =~ /Can't locate (\S+)/) {
            my $mod = $1;
            $mod =~ s/\.pm$//;
            $mod =~ s#/#::#g;
            push @errors, $mod;
        }
    }

    if (@errors) {
        my $msg = sprintf "Missing dependenc%s: %s",
            @errors == 1 ? 'y' : 'ies',
            join ", ", @errors;
        plan skip_all => $msg;
    }
    else {
        plan tests => $ntests;
    }
}

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. Testing a parsed
schema is then as easy as writing a perl data structure describing how you
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
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.

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 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.

=head1 EXPORTS

table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok,
maybe_plan

=head1 TODO

=over 4

=item Test the tests!

=item Test Count Constants

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
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 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.

=head1 SEE ALSO

perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.

=cut
Commit	Line	Data
9bbbf403	1	package Test::SQL::Translator;
	2
	3	# ----------------------------------------------------------------------
e2a489c2	4	# $Id: Translator.pm,v 1.6 2004-07-08 17:29:56 grommit Exp $
9bbbf403	5	# ----------------------------------------------------------------------
	6	# Copyright (C) 2003 The SQLFairy Authors
	7	#
	8	# This program is free software; you can redistribute it and/or
	9	# modify it under the terms of the GNU General Public License as
	10	# published by the Free Software Foundation; version 2.
	11	#
	12	# This program is distributed in the hope that it will be useful, but
	13	# WITHOUT ANY WARRANTY; without even the implied warranty of
	14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	15	# General Public License for more details.
	16	#
	17	# You should have received a copy of the GNU General Public License
	18	# along with this program; if not, write to the Free Software
	19	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	20	# 02111-1307 USA
	21	# -------------------------------------------------------------------
	22
	23	=pod
	24
	25	=head1 NAME
	26
	27	Test::SQL::Translator - Test::More test functions for the Schema objects.
	28
	29	=cut
	30
	31	use strict;
	32	use warnings;
	33
	34	use base qw(Exporter);
	35
	36	use vars qw($VERSION @EXPORT @EXPORT_OK);
e2a489c2	37	$VERSION = sprintf "%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/;
e2a489c2	38	@EXPORT = qw(
a0eb602d	39	schema_ok
9bbbf403	40	table_ok
	41	field_ok
	42	constraint_ok
	43	index_ok
	44	view_ok
	45	trigger_ok
	46	procedure_ok
49133ae7	47	maybe_plan
9bbbf403	48	);
9bbbf403	49
9bbbf403	50	use Test::More;
9bbbf403	51	use SQL::Translator::Schema::Constants;
	52
	53	# $ATTRIBUTES{ <schema_object_name> } = { <attribname> => <default>, ... }
	54	my %ATTRIBUTES;
	55	$ATTRIBUTES{field} = {
	56	name => undef,
	57	data_type => '',
	58	default_value => undef,
	59	size => '0',
	60	is_primary_key => 0,
	61	is_unique => 0,
	62	is_nullable => 1,
	63	is_foreign_key => 0,
	64	is_auto_increment => 0,
	65	comments => '',
	66	extra => {},
	67	# foreign_key_reference,
	68	is_valid => 1,
	69	# order
	70	};
	71	$ATTRIBUTES{constraint} = {
	72	name => '',
	73	type => '',
	74	deferrable => 1,
	75	expression => '',
	76	is_valid => 1,
	77	fields => [],
	78	match_type => '',
	79	options => [],
	80	on_delete => '',
	81	on_update => '',
	82	reference_fields => [],
	83	reference_table => '',
	84	};
	85	$ATTRIBUTES{'index'} = {
	86	fields => [],
	87	is_valid => 1,
	88	name => "",
	89	options => [],
	90	type => NORMAL,
	91	};
	92	$ATTRIBUTES{'view'} = {
	93	name => "",
	94	sql => "",
	95	fields => [],
a0eb602d	96	is_valid => 1,
9bbbf403	97	};
	98	$ATTRIBUTES{'trigger'} = {
	99	name => '',
	100	perform_action_when => undef,
	101	database_event => undef,
	102	on_table => undef,
	103	action => undef,
a0eb602d	104	is_valid => 1,
9bbbf403	105	};
	106	$ATTRIBUTES{'procedure'} = {
	107	name => '',
	108	sql => '',
	109	parameters => [],
	110	owner => '',
	111	comments => '',
	112	};
	113	$ATTRIBUTES{table} = {
	114	comments => undef,
	115	name => '',
	116	#primary_key => undef, # pkey constraint
	117	options => [],
	118	#order => 0,
	119	fields => undef,
	120	constraints => undef,
	121	indices => undef,
a0eb602d	122	is_valid => 1,
	123	};
	124	$ATTRIBUTES{schema} = {
	125	name => '',
	126	database => '',
	127	procedures => undef, # [] when set
	128	tables => undef, # [] when set
	129	triggers => undef, # [] when set
	130	views => undef, # [] when set
	131	is_valid => 1,
9bbbf403	132	};
	133
	134
	135
	136	# Given a test hash and schema object name set any attribute keys not present in
	137	# the test hash to their default value for that schema object type.
	138	# e.g. default_attribs( $test, "field" );
	139	sub default_attribs {
	140	my ($foo, $what) = @_;
	141	die "Can't add default attibs - unkown Scheam object type '$what'."
	142	unless exists $ATTRIBUTES{$what};
	143	$foo->{$_} = $ATTRIBUTES{$what}{$_}
	144	foreach grep !exists($foo->{$_}), keys %{$ATTRIBUTES{$what}};
	145	return $foo;
	146	}
	147
	148	# Format test name so it will prepend the test names used below.
	149	sub t_name {
	150	my $name = shift;
	151	$name \|\|= "";
	152	$name = "$name - " if $name;
	153	return $name;
	154	}
	155
	156	sub field_ok {
	157	my ($f1,$test,$name) = @_;
	158	my $t_name = t_name($name);
	159	default_attribs($test,"field");
	160
	161	unless ($f1) {
	162	fail " Field '$test->{name}' doesn't exist!";
a0eb602d	163	# TODO Do a skip on the following tests. Currently the test counts wont
a0eb602d	164	# match at the end. So at least it fails.
9bbbf403	165	return;
	166	}
	167
a0eb602d	168	my $full_name = $f1->table->name.".".$test->{name};
	169
	170	is( $f1->name, $test->{name}, "${t_name}Field '$full_name'" );
9bbbf403	171
9bbbf403	172	is( $f1->is_valid, $test->{is_valid},
a0eb602d	173	"$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
9bbbf403	174
	175	is( $f1->data_type, $test->{data_type},
	176	"$t_name type is '$test->{data_type}'" );
	177
	178	is( $f1->size, $test->{size}, "$t_name size is '$test->{size}'" );
	179
	180	is( $f1->default_value, $test->{default_value},
	181	"$t_name default value is "
	182	.(defined($test->{default_value}) ? "'$test->{default_value}'" : "UNDEF" )
	183	);
	184
	185	is( $f1->is_nullable, $test->{is_nullable},
	186	"$t_name ".($test->{is_nullable} ? 'can' : 'cannot').' be null' );
	187
	188	is( $f1->is_unique, $test->{is_unique},
	189	"$t_name ".($test->{is_unique} ? 'can' : 'cannot').' be unique' );
	190
	191	is( $f1->is_primary_key, $test->{is_primary_key},
	192	"$t_name is ".($test->{is_primary_key} ? '' : 'not ').'a primary_key' );
	193
	194	is( $f1->is_foreign_key, $test->{is_foreign_key},
	195	"$t_name is ".($test->{is_foreign_key} ? '' : 'not').' a foreign_key' );
	196
	197	is( $f1->is_auto_increment, $test->{is_auto_increment},
	198	"$t_name is "
	199	.($test->{is_auto_increment} ? '' : 'not ').'an auto_increment' );
	200
	201	is( $f1->comments, $test->{comments}, "$t_name comments" );
	202
	203	is_deeply( { $f1->extra }, $test->{extra}, "$t_name extra" );
	204	}
	205
	206	sub constraint_ok {
	207	my ($obj,$test,$name) = @_;
	208	my $t_name = t_name($name);
	209	default_attribs($test,"constraint");
	210
	211	is( $obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'" );
	212
	213	is( $obj->type, $test->{type}, "$t_name type is '$test->{type}'" );
	214
	215	is( $obj->deferrable, $test->{deferrable},
	216	"$t_name ".($test->{deferrable} ? 'can' : 'cannot').' be deferred' );
	217
	218	is( $obj->is_valid, $test->{is_valid},
	219	"$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
	220
	221	is($obj->table->name,$test->{table},"$t_name table is '$test->{table}'" );
	222
	223	is( $obj->expression, $test->{expression},
	224	"$t_name expression is '$test->{expression}'" );
	225
	226	is_deeply( [$obj->fields], $test->{fields},
	227	"$t_name fields are '".join(",",@{$test->{fields}})."'" );
	228
	229	is( $obj->reference_table, $test->{reference_table},
	230	"$t_name reference_table is '$test->{reference_table}'" );
	231
	232	is_deeply( [$obj->reference_fields], $test->{reference_fields},
	233	"$t_name reference_fields are '".join(",",@{$test->{reference_fields}})."'" );
	234
	235	is( $obj->match_type, $test->{match_type},
	236	"$t_name match_type is '$test->{match_type}'" );
	237
238	is( $obj->on_delete, $test->{on_delete},
239	"$t_name on_delete is '$test->{on_delete}'" );
240
241	is( $obj->on_update, $test->{on_update},
242	"$t_name on_update is '$test->{on_update}'" );
243
244	is_deeply( [$obj->options], $test->{options},
245	"$t_name options are '".join(",",@{$test->{options}})."'" );
246	}
247
248	sub index_ok {
249	my ($obj,$test,$name) = @_;
250	my $t_name = t_name($name);
251	default_attribs($test,"index");
252
253	is( $obj->name, $test->{name}, "${t_name}Index '$test->{name}'" );
254
255	is( $obj->is_valid, $test->{is_valid},
256	"$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
257
258	is( $obj->type, $test->{type}, "$t_name type is '$test->{type}'" );
259
260	is_deeply( [$obj->fields], $test->{fields},
261	"$t_name fields are '".join(",",@{$test->{fields}})."'" );
262
263	is_deeply( [$obj->options], $test->{options},
264	"$t_name options are '".join(",",@{$test->{options}})."'" );
265	}
266
267	sub trigger_ok {
268	my ($obj,$test,$name) = @_;
269	my $t_name = t_name($name);
270	default_attribs($test,"index");
271
272	is( $obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'" );
273
274	is( $obj->is_valid, $test->{is_valid},
275	"$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
276
277	is( $obj->perform_action_when, $test->{perform_action_when},
278	"$t_name perform_action_when is '$test->{perform_action_when}'" );
279
280	is( $obj->database_event, $test->{database_event},
281	"$t_name database_event is '$test->{database_event}'" );
282
283	is( $obj->on_table, $test->{on_table},
284	"$t_name on_table is '$test->{on_table}'" );
285
286	is( $obj->action, $test->{action}, "$t_name action is '$test->{action}'" );
287	}
288
289	sub view_ok {
290	my ($obj,$test,$name) = @_;
291	my $t_name = t_name($name);
292	default_attribs($test,"index");
293
294	#isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
295
296	is( $obj->name, $test->{name}, "${t_name}View '$test->{name}'" );
297
298	is( $obj->is_valid, $test->{is_valid},
299	"$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
300
301	is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" );
302
303	is_deeply( [$obj->fields], $test->{fields},
304	"$t_name fields are '".join(",",@{$test->{fields}})."'" );
305	}
306
307	sub procedure_ok {
308	my ($obj,$test,$name) = @_;
309	my $t_name = t_name($name);
310	default_attribs($test,"index");
311
312	#isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
313
314	is( $obj->name, $test->{name}, "${t_name}Procedure '$test->{name}'" );
315
316	is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" );
317
318	is_deeply( [$obj->parameters], $test->{parameters},
319	"$t_name parameters are '".join(",",@{$test->{parameters}})."'" );
320
321	is( $obj->comments, $test->{comments},
322	"$t_name comments is '$test->{comments}'" );
323
324	is( $obj->owner, $test->{owner}, "$t_name owner is '$test->{owner}'" );
325	}
326
327	sub table_ok {
328	my ($obj,$test,$name) = @_;
329	my $t_name = t_name($name);
330	default_attribs($test,"table");
331	my %arg = %$test;
332
333	my $tbl_name = $arg{name} \|\| die "Need a table name to test.";
a0eb602d	334	is( $obj->{name}, $arg{name}, "${t_name}Table '$arg{name}'" );
9bbbf403	335
	336	is_deeply( [$obj->options], $test->{options},
	337	"$t_name options are '".join(",",@{$test->{options}})."'" );
	338
	339	# Fields
	340	if ( $arg{fields} ) {
a0eb602d	341	my @fldnames = map {$_->{name}} @{$arg{fields}};
	342	is_deeply(
	343	[ map {$_->name} $obj->get_fields ],
	344	[ @fldnames ],
	345	"${t_name} field names are ".join(", ",@fldnames)
	346	);
9bbbf403	347	foreach ( @{$arg{fields}} ) {
9bbbf403	348	my $f_name = $_->{name} \|\| die "Need a field name to test.";
a0eb602d	349	next unless my $fld = $obj->get_field($f_name);
a0eb602d	350	field_ok( $fld, $_, $name );
9bbbf403	351	}
	352	}
	353	else {
	354	is(scalar($obj->get_fields), undef,
a0eb602d	355	"${t_name} has no fields.");
9bbbf403	356	}
9bbbf403	357
a0eb602d	358	# Constraints and Indices
a0eb602d	359	_test_kids($obj, $test, $name, {
9bbbf403	360	constraint => "constraints",
9bbbf403	361	'index' => "indices",
a0eb602d	362	});
	363	}
	364
	365	sub _test_kids {
	366	my ($obj, $test, $name, $kids) = @_;
	367	my $t_name = t_name($name);
	368	my $obj_name = ref $obj;
	369	($obj_name) = $obj_name =~ m/^.::(.)$/;
	370
	371	while ( my($foo,$plural) = each %$kids ) {
	372	next unless defined $test->{$plural};
	373	if ( my @tfoo = @{$test->{$plural}} ) {
9bbbf403	374	my $meth = "get_$plural";
	375	my @foo = $obj->$meth;
	376	is(scalar(@foo), scalar(@tfoo),
a0eb602d	377	"${t_name}$obj_name has ".scalar(@tfoo)." $plural");
9bbbf403	378	foreach ( @foo ) {
a0eb602d	379	my $ans = { lc($obj_name) => $obj->name, %{shift @tfoo}};
a0eb602d	380	#my $ans = shift @tfoo;
9bbbf403	381	my $meth = "${foo}_ok";
	382	{ no strict 'refs';
	383	$meth->( $_, $ans, $name );
	384	}
	385	}
	386	}
	387	}
	388	}
	389
	390	sub schema_ok {
	391	my ($obj,$test,$name) = @_;
	392	my $t_name = t_name($name);
	393	default_attribs($test,"schema");
a0eb602d	394
	395	is( $obj->name, $test->{name}, "${t_name}Schema name is '$test->{name}'" );
	396
	397	is( $obj->database, $test->{database},
	398	"$t_name database is '$test->{database}'" );
	399
	400	is( $obj->is_valid, $test->{is_valid},
	401	"$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
	402
	403	# Tables
	404	if ( $test->{tables} ) {
	405	is_deeply( [ map {$_->name} $obj->get_tables ],
	406	[ map {$_->{name}} @{$test->{tables}} ],
	407	"${t_name} table names match" );
	408	foreach ( @{$test->{tables}} ) {
	409	my $t_name = $_->{name} \|\| die "Need a table name to test.";
	410	table_ok( $obj->get_table($t_name), $_, $name );
	411	}
	412	}
	413	else {
	414	is(scalar($obj->get_tables), undef,
	415	"${t_name} has no tables.");
	416	}
	417
	418	# Procedures, Triggers, Views
	419	_test_kids($obj, $test, $name, {
	420	procedure => "procedures",
	421	trigger => "triggers",
	422	view => "views",
	423	});
9bbbf403	424	}
9bbbf403	425
49133ae7	426	# maybe_plan($ntests, @modules)
	427	#
	428	# Calls plan $ntests if @modules can all be loaded; otherwise,
	429	# calls skip_all with an explanation of why the tests were skipped.
	430	sub maybe_plan {
	431	my ($ntests, @modules) = @_;
	432	my @errors;
	433
	434	for my $module (@modules) {
	435	eval "use $module;";
	436	if ($@ && $@ =~ /Can't locate (\S+)/) {
	437	my $mod = $1;
	438	$mod =~ s/\.pm$//;
	439	$mod =~ s#/#::#g;
	440	push @errors, $mod;
	441	}
	442	}
	443
	444	if (@errors) {
	445	my $msg = sprintf "Missing dependenc%s: %s",
	446	@errors == 1 ? 'y' : 'ies',
	447	join ", ", @errors;
	448	plan skip_all => $msg;
	449	}
	450	else {
	451	plan tests => $ntests;
	452	}
	453	}
	454
9bbbf403	455	1; # compile please ===========================================================
	456	__END__
	457
	458	=pod
	459
	460	=head1 SYNOPSIS
	461
	462	# t/magic.t
	463
	464	use FindBin '$Bin';
	465	use Test::More;
	466	use Test::SQL::Translator;
	467
	468	# Run parse
	469	my $sqlt = SQL::Translator->new(
	470	parser => "Magic",
	471	filename => "$Bin/data/magic/test.magic",
e2a489c2	472	...
9bbbf403	473	);
	474	...
	475	my $schema = $sqlt->schema;
e2a489c2	476
9bbbf403	477	# Test the table it produced.
	478	table_ok( $schema->get_table("Customer"), {
	479	name => "Customer",
	480	fields => [
	481	{
	482	name => "CustomerID",
	483	data_type => "INT",
	484	size => 12,
	485	default_value => undef,
	486	is_nullable => 0,
	487	is_primary_key => 1,
	488	},
	489	{
	490	name => "bar",
	491	data_type => "VARCHAR",
	492	size => 255,
	493	is_nullable => 0,
	494	},
	495	],
	496	constraints => [
	497	{
	498	type => "PRIMARY KEY",
	499	fields => "CustomerID",
	500	},
	501	],
	502	indices => [
	503	{
	504	name => "barindex",
	505	fields => ["bar"],
	506	},
	507	],
	508	});
	509
	510	=head1 DESCSIPTION
	511
e2a489c2	512	Provides a set of Test::More tests for Schema objects. Testing a parsed
9bbbf403	513	schema is then as easy as writing a perl data structure describing how you
e2a489c2	514	expect the schema to look. Also provides maybe_plan for conditionally running
e2a489c2	515	tests based on their dependencies.
9bbbf403	516
e2a489c2	517	The data structures given to the test subs don't have to include all the
9bbbf403	518	possible values, only the ones you expect to have changed. Any left out will be
	519	tested to make sure they are still at their default value. This is a usefull
	520	check that you your parser hasn't accidentally set schema values you didn't
e2a489c2	521	expect it to.
9bbbf403	522
	523	For an example of the output run the t/16xml-parser.t test.
	524
	525	=head1 Tests
	526
e2a489c2	527	All the tests take a first arg of the schema object to test, followed by a
9bbbf403	528	hash ref describing how you expect that object to look (you only need give the
9bbbf403	529	attributes you expect to have changed from the default).
e2a489c2	530	The 3rd arg is an optional test name to pre-pend to all the generated test
9bbbf403	531	names.
	532
	533	=head2 table_ok
	534
	535	=head2 field_ok
	536
	537	=head2 constraint_ok
	538
	539	=head2 index_ok
	540
	541	=head2 view_ok
	542
	543	=head2 trigger_ok
	544
	545	=head2 procedure_ok
	546
49133ae7	547	=head1 CONDITIONAL TESTS
	548
	549	The C<maybe_plan> function handles conditionally running an individual
	550	test. It is here to enable running the test suite even when dependencies
	551	are missing; not having (for example) GraphViz installed should not keep
	552	the test suite from passing.
	553
	554	C<maybe_plan> takes the number of tests to (maybe) run, and a list of
	555	modules on which test execution depends:
	556
	557	maybe_plan(180, 'SQL::Translator::Parser::MySQL');
	558
	559	If one of C<SQL::Translator::Parser::MySQL>'s dependencies does not exist,
	560	then the test will be skipped.
	561
9bbbf403	562	=head1 EXPORTS
9bbbf403	563
49133ae7	564	table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok,
49133ae7	565	maybe_plan
9bbbf403	566
	567	=head1 TODO
	568
	569	=over 4
	570
	571	=item Test the tests!
	572
19458c2f	573	=item Test Count Constants
19458c2f	574
e2a489c2	575	Constants to give the number of tests each *_ok sub uses. e.g. How many tests
19458c2f	576	does field_ok run? Can then use these to set up the test plan easily.
19458c2f	577
9bbbf403	578	=item Test skipping
	579
	580	As the test subs wrap up lots of tests in one call you can't skip idividual
	581	tests only whole sets e.g. a whole table or field.
	582	We could add skip_* items to the test hashes to allow per test skips. e.g.
	583
	584	skip_is_primary_key => "Need to fix primary key parsing.",
	585
	586	=item yaml test specs
	587
	588	Maybe have the test subs also accept yaml for the test hash ref as its a much
	589	nicer for writing big data structures. We can then define tests as in input
	590	schema file and test yaml file to compare it against.
	591
	592	=back
	593
	594	=head1 BUGS
	595
	596	=head1 AUTHOR
	597
e2a489c2	598	Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>, Darren Chamberlain <darren@cpan.org>.
9bbbf403	599
	600	Thanks to Ken Y. Clark for the original table and field test code taken from
	601	his mysql test.
	602
	603	=head1 SEE ALSO
	604
	605	perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.
	606
	607	=cut