1 package Test::SQL::Translator;
3 # ----------------------------------------------------------------------
4 # $Id: Translator.pm,v 1.1 2004-02-29 18:26:53 grommit Exp $
5 # ----------------------------------------------------------------------
6 # Copyright (C) 2003 The SQLFairy Authors
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.
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.
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
21 # -------------------------------------------------------------------
27 Test::SQL::Translator - Test::More test functions for the Schema objects.
34 use base qw(Exporter);
36 use vars qw($VERSION @EXPORT @EXPORT_OK);
37 $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
51 use SQL::Translator::Schema::Constants;
53 # $ATTRIBUTES{ <schema_object_name> } = { <attribname> => <default>, ... }
55 $ATTRIBUTES{field} = {
58 default_value => undef,
64 is_auto_increment => 0,
67 # foreign_key_reference,
71 $ATTRIBUTES{constraint} = {
82 reference_fields => [],
83 reference_table => '',
85 $ATTRIBUTES{'index'} = {
92 $ATTRIBUTES{'view'} = {
97 $ATTRIBUTES{'trigger'} = {
99 perform_action_when => undef,
100 database_event => undef,
104 $ATTRIBUTES{'procedure'} = {
111 $ATTRIBUTES{table} = {
114 #primary_key => undef, # pkey constraint
118 constraints => undef,
124 # Given a test hash and schema object name set any attribute keys not present in
125 # the test hash to their default value for that schema object type.
126 # e.g. default_attribs( $test, "field" );
127 sub default_attribs {
128 my ($foo, $what) = @_;
129 die "Can't add default attibs - unkown Scheam object type '$what'."
130 unless exists $ATTRIBUTES{$what};
131 $foo->{$_} = $ATTRIBUTES{$what}{$_}
132 foreach grep !exists($foo->{$_}), keys %{$ATTRIBUTES{$what}};
136 # Format test name so it will prepend the test names used below.
140 $name = "$name - " if $name;
145 my ($f1,$test,$name) = @_;
146 my $t_name = t_name($name);
147 default_attribs($test,"field");
150 fail " Field '$test->{name}' doesn't exist!";
154 is( $f1->name, $test->{name}, "${t_name}Field name '$test->{name}'" );
156 is( $f1->is_valid, $test->{is_valid},
157 "$t_name is".($test->{is_valid} ? '' : 'not ').'valid' );
159 is( $f1->data_type, $test->{data_type},
160 "$t_name type is '$test->{data_type}'" );
162 is( $f1->size, $test->{size}, "$t_name size is '$test->{size}'" );
164 is( $f1->default_value, $test->{default_value},
165 "$t_name default value is "
166 .(defined($test->{default_value}) ? "'$test->{default_value}'" : "UNDEF" )
169 is( $f1->is_nullable, $test->{is_nullable},
170 "$t_name ".($test->{is_nullable} ? 'can' : 'cannot').' be null' );
172 is( $f1->is_unique, $test->{is_unique},
173 "$t_name ".($test->{is_unique} ? 'can' : 'cannot').' be unique' );
175 is( $f1->is_primary_key, $test->{is_primary_key},
176 "$t_name is ".($test->{is_primary_key} ? '' : 'not ').'a primary_key' );
178 is( $f1->is_foreign_key, $test->{is_foreign_key},
179 "$t_name is ".($test->{is_foreign_key} ? '' : 'not').' a foreign_key' );
181 is( $f1->is_auto_increment, $test->{is_auto_increment},
183 .($test->{is_auto_increment} ? '' : 'not ').'an auto_increment' );
185 is( $f1->comments, $test->{comments}, "$t_name comments" );
187 is_deeply( { $f1->extra }, $test->{extra}, "$t_name extra" );
191 my ($obj,$test,$name) = @_;
192 my $t_name = t_name($name);
193 default_attribs($test,"constraint");
195 is( $obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'" );
197 is( $obj->type, $test->{type}, "$t_name type is '$test->{type}'" );
199 is( $obj->deferrable, $test->{deferrable},
200 "$t_name ".($test->{deferrable} ? 'can' : 'cannot').' be deferred' );
202 is( $obj->is_valid, $test->{is_valid},
203 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
205 is($obj->table->name,$test->{table},"$t_name table is '$test->{table}'" );
207 is( $obj->expression, $test->{expression},
208 "$t_name expression is '$test->{expression}'" );
210 is_deeply( [$obj->fields], $test->{fields},
211 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
213 is( $obj->reference_table, $test->{reference_table},
214 "$t_name reference_table is '$test->{reference_table}'" );
216 is_deeply( [$obj->reference_fields], $test->{reference_fields},
217 "$t_name reference_fields are '".join(",",@{$test->{reference_fields}})."'" );
219 is( $obj->match_type, $test->{match_type},
220 "$t_name match_type is '$test->{match_type}'" );
222 is( $obj->on_delete, $test->{on_delete},
223 "$t_name on_delete is '$test->{on_delete}'" );
225 is( $obj->on_update, $test->{on_update},
226 "$t_name on_update is '$test->{on_update}'" );
228 is_deeply( [$obj->options], $test->{options},
229 "$t_name options are '".join(",",@{$test->{options}})."'" );
233 my ($obj,$test,$name) = @_;
234 my $t_name = t_name($name);
235 default_attribs($test,"index");
237 is( $obj->name, $test->{name}, "${t_name}Index '$test->{name}'" );
239 is( $obj->is_valid, $test->{is_valid},
240 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
242 is( $obj->type, $test->{type}, "$t_name type is '$test->{type}'" );
244 is_deeply( [$obj->fields], $test->{fields},
245 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
247 is_deeply( [$obj->options], $test->{options},
248 "$t_name options are '".join(",",@{$test->{options}})."'" );
252 my ($obj,$test,$name) = @_;
253 my $t_name = t_name($name);
254 default_attribs($test,"index");
256 is( $obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'" );
258 is( $obj->is_valid, $test->{is_valid},
259 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
261 is( $obj->perform_action_when, $test->{perform_action_when},
262 "$t_name perform_action_when is '$test->{perform_action_when}'" );
264 is( $obj->database_event, $test->{database_event},
265 "$t_name database_event is '$test->{database_event}'" );
267 is( $obj->on_table, $test->{on_table},
268 "$t_name on_table is '$test->{on_table}'" );
270 is( $obj->action, $test->{action}, "$t_name action is '$test->{action}'" );
274 my ($obj,$test,$name) = @_;
275 my $t_name = t_name($name);
276 default_attribs($test,"index");
278 #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
280 is( $obj->name, $test->{name}, "${t_name}View '$test->{name}'" );
282 is( $obj->is_valid, $test->{is_valid},
283 "$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
285 is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" );
287 is_deeply( [$obj->fields], $test->{fields},
288 "$t_name fields are '".join(",",@{$test->{fields}})."'" );
292 my ($obj,$test,$name) = @_;
293 my $t_name = t_name($name);
294 default_attribs($test,"index");
296 #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
298 is( $obj->name, $test->{name}, "${t_name}Procedure '$test->{name}'" );
300 is( $obj->sql, $test->{sql}, "$t_name sql is '$test->{sql}'" );
302 is_deeply( [$obj->parameters], $test->{parameters},
303 "$t_name parameters are '".join(",",@{$test->{parameters}})."'" );
305 is( $obj->comments, $test->{comments},
306 "$t_name comments is '$test->{comments}'" );
308 is( $obj->owner, $test->{owner}, "$t_name owner is '$test->{owner}'" );
312 my ($obj,$test,$name) = @_;
313 my $t_name = t_name($name);
314 default_attribs($test,"table");
317 my $tbl_name = $arg{name} || die "Need a table name to test.";
318 is( $obj->{name}, $arg{name}, "${t_name}Table name '$arg{name}'" );
320 is_deeply( [$obj->options], $test->{options},
321 "$t_name options are '".join(",",@{$test->{options}})."'" );
324 if ( $arg{fields} ) {
325 my @fldnames = map { $_->{name} } @{$arg{fields}};
326 is_deeply( [ map {$_->name} $obj->get_fields ],
327 [ map {$_->{name}} @{$arg{fields}} ],
328 "${t_name}Table $tbl_name fields match" );
329 foreach ( @{$arg{fields}} ) {
330 my $f_name = $_->{name} || die "Need a field name to test.";
331 field_ok( $obj->get_field($f_name), $_, $name );
335 is(scalar($obj->get_fields), undef,
336 "${t_name}Table $tbl_name has no fields.");
339 # Constraints and indices
341 constraint => "constraints",
342 'index' => "indices",
344 while ( my($foo,$plural) = each %bits ) {
345 next unless defined $arg{$plural};
346 if ( my @tfoo = @{$arg{$plural}} ) {
347 my $meth = "get_$plural";
348 my @foo = $obj->$meth;
349 is(scalar(@foo), scalar(@tfoo),
350 "${t_name}Table $tbl_name has ".scalar(@tfoo)." $plural");
352 my $ans = { table => $obj->name, %{shift @tfoo}};
353 my $meth = "${foo}_ok";
355 $meth->( $_, $ans, $name );
363 my ($obj,$test,$name) = @_;
364 my $t_name = t_name($name);
365 default_attribs($test,"schema");
368 1; # compile please ===========================================================
379 use Test::SQL::Translator;
382 my $sqlt = SQL::Translator->new(
384 filename => "$Bin/data/magic/test.magic",
388 my $schema = $sqlt->schema;
390 # Test the table it produced.
391 table_ok( $schema->get_table("Customer"), {
395 name => "CustomerID",
398 default_value => undef,
404 data_type => "VARCHAR",
411 type => "PRIMARY KEY",
412 fields => "CustomerID",
425 Provides a set of Test::More tests for Schema objects. Tesing a parsed
426 schema is then as easy as writing a perl data structure describing how you
427 expect the schema to look.
429 The data structures given to the test subs don't have to include all the
430 possible values, only the ones you expect to have changed. Any left out will be
431 tested to make sure they are still at their default value. This is a usefull
432 check that you your parser hasn't accidentally set schema values you didn't
433 expect it to. (And makes tests look nice and long ;-)
435 For an example of the output run the t/16xml-parser.t test.
439 All the tests take a first arg of the schema object to test, followed by a
440 hash ref describing how you expect that object to look (you only need give the
441 attributes you expect to have changed from the default).
442 The 3rd arg is an optional test name to pre-pend to all the generated test
461 table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok
467 =item Test the tests!
475 As the test subs wrap up lots of tests in one call you can't skip idividual
476 tests only whole sets e.g. a whole table or field.
477 We could add skip_* items to the test hashes to allow per test skips. e.g.
479 skip_is_primary_key => "Need to fix primary key parsing.",
481 =item yaml test specs
483 Maybe have the test subs also accept yaml for the test hash ref as its a much
484 nicer for writing big data structures. We can then define tests as in input
485 schema file and test yaml file to compare it against.
493 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
495 Thanks to Ken Y. Clark for the original table and field test code taken from
500 perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.