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

package Test::SQL::Translator;

# ----------------------------------------------------------------------
# $Id: Translator.pm,v 1.4 2004-03-04 14:41:49 dlc 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.4 $ =~ /(\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 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",
    });
}

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

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