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

package Test::SQL::Translator;

# ----------------------------------------------------------------------
# $Id: Translator.pm,v 1.2 2004-02-29 20:10:35 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.2 $ =~ /(\d+)\.(\d+)/;
@EXPORT = qw( 
    schema_ok
    table_ok
    field_ok
    constraint_ok
    index_ok
    view_ok
    trigger_ok
    procedure_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 => [],
    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",
    });
}

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 E<lt>mark.addison@itn.co.ukE<gt>.

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	# ----------------------------------------------------------------------
a0eb602d	4	# $Id: Translator.pm,v 1.2 2004-02-29 20:10:35 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);
a0eb602d	37	$VERSION = sprintf "%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/;
9bbbf403	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
	47	);
9bbbf403	48
	49	use Test::More;
	50	use Test::Exception;
	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
a0eb602d	390
a0eb602d	391
9bbbf403	392	sub schema_ok {
	393	my ($obj,$test,$name) = @_;
	394	my $t_name = t_name($name);
	395	default_attribs($test,"schema");
a0eb602d	396
	397	is( $obj->name, $test->{name}, "${t_name}Schema name is '$test->{name}'" );
	398
	399	is( $obj->database, $test->{database},
	400	"$t_name database is '$test->{database}'" );
	401
	402	is( $obj->is_valid, $test->{is_valid},
	403	"$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
	404
	405	# Tables
	406	if ( $test->{tables} ) {
	407	is_deeply( [ map {$_->name} $obj->get_tables ],
	408	[ map {$_->{name}} @{$test->{tables}} ],
	409	"${t_name} table names match" );
	410	foreach ( @{$test->{tables}} ) {
	411	my $t_name = $_->{name} \|\| die "Need a table name to test.";
	412	table_ok( $obj->get_table($t_name), $_, $name );
	413	}
	414	}
	415	else {
	416	is(scalar($obj->get_tables), undef,
	417	"${t_name} has no tables.");
	418	}
	419
	420	# Procedures, Triggers, Views
	421	_test_kids($obj, $test, $name, {
	422	procedure => "procedures",
	423	trigger => "triggers",
	424	view => "views",
	425	});
9bbbf403	426	}
	427
	428	1; # compile please ===========================================================
	429	__END__
	430
	431	=pod
	432
	433	=head1 SYNOPSIS
	434
	435	# t/magic.t
	436
	437	use FindBin '$Bin';
	438	use Test::More;
	439	use Test::SQL::Translator;
	440
	441	# Run parse
	442	my $sqlt = SQL::Translator->new(
	443	parser => "Magic",
	444	filename => "$Bin/data/magic/test.magic",
	445	...
	446	);
	447	...
	448	my $schema = $sqlt->schema;
	449
	450	# Test the table it produced.
	451	table_ok( $schema->get_table("Customer"), {
	452	name => "Customer",
	453	fields => [
	454	{
	455	name => "CustomerID",
	456	data_type => "INT",
	457	size => 12,
	458	default_value => undef,
	459	is_nullable => 0,
	460	is_primary_key => 1,
	461	},
	462	{
	463	name => "bar",
	464	data_type => "VARCHAR",
	465	size => 255,
	466	is_nullable => 0,
	467	},
	468	],
	469	constraints => [
	470	{
	471	type => "PRIMARY KEY",
	472	fields => "CustomerID",
	473	},
	474	],
	475	indices => [
	476	{
	477	name => "barindex",
	478	fields => ["bar"],
	479	},
	480	],
	481	});
	482
	483	=head1 DESCSIPTION
	484
	485	Provides a set of Test::More tests for Schema objects. Tesing a parsed
	486	schema is then as easy as writing a perl data structure describing how you
	487	expect the schema to look.
	488
	489	The data structures given to the test subs don't have to include all the
490	possible values, only the ones you expect to have changed. Any left out will be
491	tested to make sure they are still at their default value. This is a usefull
492	check that you your parser hasn't accidentally set schema values you didn't
493	expect it to. (And makes tests look nice and long ;-)
494
495	For an example of the output run the t/16xml-parser.t test.
496
497	=head1 Tests
498
499	All the tests take a first arg of the schema object to test, followed by a
500	hash ref describing how you expect that object to look (you only need give the
501	attributes you expect to have changed from the default).
502	The 3rd arg is an optional test name to pre-pend to all the generated test
503	names.
504
505	=head2 table_ok
506
507	=head2 field_ok
508
509	=head2 constraint_ok
510
511	=head2 index_ok
512
513	=head2 view_ok
514
515	=head2 trigger_ok
516
517	=head2 procedure_ok
518
519	=head1 EXPORTS
520
521	table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok
522
523	=head1 TODO
524
525	=over 4
526
527	=item Test the tests!
528
529	=item schema_ok()
530
531	Test whole schema.
532
533	=item Test skipping
534
535	As the test subs wrap up lots of tests in one call you can't skip idividual
536	tests only whole sets e.g. a whole table or field.
537	We could add skip_* items to the test hashes to allow per test skips. e.g.
538
539	skip_is_primary_key => "Need to fix primary key parsing.",
540
541	=item yaml test specs
542
543	Maybe have the test subs also accept yaml for the test hash ref as its a much
544	nicer for writing big data structures. We can then define tests as in input
545	schema file and test yaml file to compare it against.
546
547	=back
548
549	=head1 BUGS
550
551	=head1 AUTHOR
552
553	Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
554
555	Thanks to Ken Y. Clark for the original table and field test code taken from
556	his mysql test.
557
558	=head1 SEE ALSO
559
560	perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.
561
562	=cut