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

package Test::SQL::Translator;

# ----------------------------------------------------------------------
# $Id: Translator.pm,v 1.7 2004-11-05 15:03:10 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.7 $ =~ /(\d+)\.(\d+)/;
@EXPORT = qw(
    schema_ok
    table_ok
    field_ok
    constraint_ok
    index_ok
    view_ok
    trigger_ok
    procedure_ok
    maybe_plan
);

use Test::More;
use SQL::Translator::Schema::Constants;

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