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

package Test::SQL::Translator;

# ----------------------------------------------------------------------
# Copyright (C) 2003 The SQLFairy Authors
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

=pod

=head1 NAME

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 = '1.59';
@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 => '',
    extra => {},
};
$ATTRIBUTES{'index'} = {
    fields => [],
    is_valid => 1,
    name => "",
    options => [],
    type => NORMAL,
    extra => {},
};
$ATTRIBUTES{'view'} = {
    name => "",
    sql => "",
    fields => [],
    is_valid  => 1,
    extra => {},
};
$ATTRIBUTES{'trigger'} = {
    name                => '',
    perform_action_when => undef,
    database_event      => undef,
    on_table            => undef,
    action              => undef,
    is_valid            => 1,
    extra => {},
};
$ATTRIBUTES{'procedure'} = {
    name       => '',
    sql        => '',
    parameters => [],
    owner      => '',
    comments   => '',
    extra => {},
};
$ATTRIBUTES{table} = {
    comments   => undef,
    name       => '',
    #primary_key => undef, # pkey constraint
    options    => [],
    #order      => 0,
    fields      => undef,
    constraints => undef,
    indices     => undef,
    is_valid    => 1,
    extra       => {},
};
$ATTRIBUTES{schema} = {
    name       => '',
    database   => '',
    procedures => undef, # [] when set
    tables     => undef, # [] when set
    triggers   => undef, # [] when set
    views      => undef, # [] when set
    is_valid   => 1,
    extra => {},
};


# 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}})."'" );
    
    is_deeply( { $obj->extra }, $test->{extra}, "$t_name    extra" );
}

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}})."'" );
    
    is_deeply( { $obj->extra }, $test->{extra}, "$t_name    extra" );
}

sub trigger_ok {
    my ($obj,$test,$name) = @_;
    my $t_name = t_name($name);
    default_attribs($test,"index");

    is( $obj->name, $test->{name}, "${t_name}Trigger '$test->{name}'" );

    is( $obj->is_valid, $test->{is_valid},
        "$t_name    is ".($test->{is_valid} ? '' : 'not ').'valid' );

    is( $obj->perform_action_when, $test->{perform_action_when},
        "$t_name    perform_action_when is '$test->{perform_action_when}'" );

    is( $obj->database_event, $test->{database_event},
        "$t_name    database_event is '$test->{database_event}'" );

    is( $obj->on_table, $test->{on_table},
        "$t_name    on_table is '$test->{on_table}'" );

    is( $obj->action, $test->{action}, "$t_name    action is '$test->{action}'" );
    
    is_deeply( { $obj->extra }, $test->{extra}, "$t_name    extra" );
}

sub view_ok {
    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}})."'" );
    
    is_deeply( { $obj->extra }, $test->{extra}, "$t_name    extra" );
}

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}'" );
   
    is_deeply( { $obj->extra }, $test->{extra}, "$t_name    extra" );
}

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}})."'" );

    is_deeply( { $obj->extra }, $test->{extra}, "$t_name    extra" );

    # 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_deeply( { $obj->extra }, $test->{extra}, "$t_name    extra" );

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