lib/Test/SQL/Translator.pm

   1 package Test::SQL::Translator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Translator.pm,v 1.1 2004-02-29 18:26:53 grommit Exp $
   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);
  37 $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
  38 @EXPORT = qw(
  39     table_ok
  40     field_ok
  41     constraint_ok
  42     index_ok
  43     view_ok
  44     trigger_ok
  45     procedure_ok
  46 );
  47 # TODO schema_ok
  48
  49 use Test::More;
  50 use Test::Exception;
  51 use SQL::Translator::Schema::Constants;
  52
  53 # $ATTRIBUTES{ <schema_object_name> } = { <attribname> => <default>, ... }
  54 my %ATTRIBUTES;
  55 $ATTRIBUTES{field} = {
  56     name => undef,
  57     data_type => '',
  58     default_value => undef,
  59     size => '0',
  60     is_primary_key => 0,
  61     is_unique => 0,
  62     is_nullable => 1,
  63     is_foreign_key => 0,
  64     is_auto_increment => 0,
  65     comments => '',
  66     extra => {},
  67     # foreign_key_reference,
  68     is_valid => 1,
  69     # order
  70 };
  71 $ATTRIBUTES{constraint} = {
  72     name => '',
  73     type => '',
  74     deferrable => 1,
  75     expression => '',
  76     is_valid => 1,
  77     fields => [],
  78     match_type => '',
  79     options => [],
  80     on_delete => '',
  81     on_update => '',
  82     reference_fields => [],
  83     reference_table => '',
  84 };
  85 $ATTRIBUTES{'index'} = {
  86     fields => [],
  87     is_valid => 1,
  88     name => "",
  89     options => [],
  90     type => NORMAL,
  91 };
  92 $ATTRIBUTES{'view'} = {
  93     name => "",
  94     sql => "",
  95     fields => [],
  96 };
  97 $ATTRIBUTES{'trigger'} = {
  98     name                => '',
  99     perform_action_when => undef,
 100     database_event      => undef,
 101     on_table            => undef,
 102     action              => undef,
 103 };
 104 $ATTRIBUTES{'procedure'} = {
 105     name       => '',
 106     sql        => '',
 107     parameters => [],
 108     owner      => '',
 109     comments   => '',
 110 };
 111 $ATTRIBUTES{table} = {
 112     comments   => undef,
 113     name       => '',
 114     #primary_key => undef, # pkey constraint
 115     options    => [],
 116     #order      => 0,
 117     fields      => undef,
 118     constraints => undef,
 119     indices     => undef,
 120 };
 121
 122
 123
 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}};
 133     return $foo;
 134 }
 135
 136 # Format test name so it will prepend the test names used below.
 137 sub t_name {
 138     my $name = shift;
 139     $name ||= "";
 140     $name = "$name - " if $name;
 141     return $name;
 142 }
 143
 144 sub field_ok {
 145     my ($f1,$test,$name) = @_;
 146     my $t_name = t_name($name);
 147     default_attribs($test,"field");
 148
 149     unless ($f1) {
 150         fail " Field '$test->{name}' doesn't exist!";
 151         return;
 152     }
 153
 154     is( $f1->name, $test->{name}, "${t_name}Field name '$test->{name}'" );
 155
 156     is( $f1->is_valid, $test->{is_valid},
 157     "$t_name    is".($test->{is_valid} ? '' : 'not ').'valid' );
 158
 159     is( $f1->data_type, $test->{data_type},
 160         "$t_name    type is '$test->{data_type}'" );
 161
 162     is( $f1->size, $test->{size}, "$t_name    size is '$test->{size}'" );
 163
 164     is( $f1->default_value, $test->{default_value},
 165     "$t_name    default value is "
 166     .(defined($test->{default_value}) ? "'$test->{default_value}'" : "UNDEF" )
 167     );
 168
 169     is( $f1->is_nullable, $test->{is_nullable},
 170     "$t_name    ".($test->{is_nullable} ? 'can' : 'cannot').' be null' );
 171
 172     is( $f1->is_unique, $test->{is_unique},
 173     "$t_name    ".($test->{is_unique} ? 'can' : 'cannot').' be unique' );
 174
 175     is( $f1->is_primary_key, $test->{is_primary_key},
 176     "$t_name    is ".($test->{is_primary_key} ? '' : 'not ').'a primary_key' );
 177
 178     is( $f1->is_foreign_key, $test->{is_foreign_key},
 179     "$t_name    is ".($test->{is_foreign_key} ? '' : 'not').' a foreign_key' );
 180
 181     is( $f1->is_auto_increment, $test->{is_auto_increment},
 182     "$t_name    is "
 183     .($test->{is_auto_increment} ?  '' : 'not ').'an auto_increment' );
 184
 185     is( $f1->comments, $test->{comments}, "$t_name    comments" );
 186
 187     is_deeply( { $f1->extra }, $test->{extra}, "$t_name    extra" );
 188 }
 189
 190 sub constraint_ok {
 191     my ($obj,$test,$name) = @_;
 192     my $t_name = t_name($name);
 193     default_attribs($test,"constraint");
 194
 195     is( $obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'" );
 196
 197     is( $obj->type, $test->{type}, "$t_name    type is '$test->{type}'" );
 198
 199     is( $obj->deferrable, $test->{deferrable},
 200     "$t_name    ".($test->{deferrable} ? 'can' : 'cannot').' be deferred' );
 201
 202     is( $obj->is_valid, $test->{is_valid},
 203     "$t_name    is ".($test->{is_valid} ? '' : 'not ').'valid' );
 204
 205     is($obj->table->name,$test->{table},"$t_name    table is '$test->{table}'" );
 206
 207     is( $obj->expression, $test->{expression},
 208     "$t_name    expression is '$test->{expression}'" );
 209
 210     is_deeply( [$obj->fields], $test->{fields},
 211     "$t_name    fields are '".join(",",@{$test->{fields}})."'" );
 212
 213     is( $obj->reference_table, $test->{reference_table},
 214     "$t_name    reference_table is '$test->{reference_table}'" );
 215
 216     is_deeply( [$obj->reference_fields], $test->{reference_fields},
 217     "$t_name    reference_fields are '".join(",",@{$test->{reference_fields}})."'" );
 218
 219     is( $obj->match_type, $test->{match_type},
 220     "$t_name    match_type is '$test->{match_type}'" );
 221
 222     is( $obj->on_delete, $test->{on_delete},
 223     "$t_name    on_delete is '$test->{on_delete}'" );
 224
 225     is( $obj->on_update, $test->{on_update},
 226     "$t_name    on_update is '$test->{on_update}'" );
 227
 228     is_deeply( [$obj->options], $test->{options},
 229     "$t_name    options are '".join(",",@{$test->{options}})."'" );
 230 }
 231
 232 sub index_ok {
 233     my ($obj,$test,$name) = @_;
 234     my $t_name = t_name($name);
 235     default_attribs($test,"index");
 236
 237     is( $obj->name, $test->{name}, "${t_name}Index '$test->{name}'" );
 238
 239     is( $obj->is_valid, $test->{is_valid},
 240     "$t_name    is ".($test->{is_valid} ? '' : 'not ').'valid' );
 241
 242     is( $obj->type, $test->{type}, "$t_name    type is '$test->{type}'" );
 243
 244     is_deeply( [$obj->fields], $test->{fields},
 245     "$t_name    fields are '".join(",",@{$test->{fields}})."'" );
 246
 247     is_deeply( [$obj->options], $test->{options},
 248     "$t_name    options are '".join(",",@{$test->{options}})."'" );
 249 }
 250
 251 sub trigger_ok {
 252     my ($obj,$test,$name) = @_;
 253     my $t_name = t_name($name);
 254     default_attribs($test,"index");
 255
 256     is( $obj->name, $test->{name}, "${t_name}Constraint '$test->{name}'" );
 257
 258     is( $obj->is_valid, $test->{is_valid},
 259         "$t_name    is ".($test->{is_valid} ? '' : 'not ').'valid' );
 260
 261     is( $obj->perform_action_when, $test->{perform_action_when},
 262         "$t_name    perform_action_when is '$test->{perform_action_when}'" );
 263
 264     is( $obj->database_event, $test->{database_event},
 265         "$t_name    database_event is '$test->{database_event}'" );
 266
 267     is( $obj->on_table, $test->{on_table},
 268         "$t_name    on_table is '$test->{on_table}'" );
 269
 270     is( $obj->action, $test->{action}, "$t_name    action is '$test->{action}'" );
 271 }
 272
 273 sub view_ok {
 274     my ($obj,$test,$name) = @_;
 275     my $t_name = t_name($name);
 276     default_attribs($test,"index");
 277
 278     #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
 279
 280     is( $obj->name, $test->{name}, "${t_name}View '$test->{name}'" );
 281
 282     is( $obj->is_valid, $test->{is_valid},
 283     "$t_name    is ".($test->{is_valid} ? '' : 'not ').'valid' );
 284
 285     is( $obj->sql, $test->{sql}, "$t_name    sql is '$test->{sql}'" );
 286
 287     is_deeply( [$obj->fields], $test->{fields},
 288     "$t_name    fields are '".join(",",@{$test->{fields}})."'" );
 289 }
 290
 291 sub procedure_ok {
 292     my ($obj,$test,$name) = @_;
 293     my $t_name = t_name($name);
 294     default_attribs($test,"index");
 295
 296     #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
 297
 298     is( $obj->name, $test->{name}, "${t_name}Procedure '$test->{name}'" );
 299
 300     is( $obj->sql, $test->{sql}, "$t_name    sql is '$test->{sql}'" );
 301
 302     is_deeply( [$obj->parameters], $test->{parameters},
 303     "$t_name    parameters are '".join(",",@{$test->{parameters}})."'" );
 304
 305     is( $obj->comments, $test->{comments},
 306         "$t_name    comments is '$test->{comments}'" );
 307
 308     is( $obj->owner, $test->{owner}, "$t_name    owner is '$test->{owner}'" );
 309 }
 310
 311 sub table_ok {
 312     my ($obj,$test,$name) = @_;
 313     my $t_name = t_name($name);
 314     default_attribs($test,"table");
 315     my %arg = %$test;
 316
 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}'" );
 319
 320     is_deeply( [$obj->options], $test->{options},
 321     "$t_name    options are '".join(",",@{$test->{options}})."'" );
 322
 323     # Fields
 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 );
 332         }
 333     }
 334     else {
 335         is(scalar($obj->get_fields), undef,
 336             "${t_name}Table $tbl_name has no fields.");
 337     }
 338
 339     # Constraints and indices
 340     my %bits = (
 341         constraint => "constraints",
 342         'index'    => "indices",
 343     );
 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");
 351             foreach ( @foo ) {
 352                 my $ans = { table => $obj->name, %{shift @tfoo}};
 353                 my $meth = "${foo}_ok";
 354                 { no strict 'refs';
 355                     $meth->( $_, $ans, $name  );
 356                 }
 357             }
 358         }
 359     }
 360 }
 361
 362 sub schema_ok {
 363     my ($obj,$test,$name) = @_;
 364     my $t_name = t_name($name);
 365     default_attribs($test,"schema");
 366 }
 367
 368 1; # compile please ===========================================================
 369 __END__
 370
 371 =pod
 372
 373 =head1 SYNOPSIS
 374
 375  # t/magic.t
 376
 377  use FindBin '$Bin';
 378  use Test::More;
 379  use Test::SQL::Translator;
 380
 381  # Run parse
 382  my $sqlt = SQL::Translator->new(
 383      parser => "Magic",
 384      filename => "$Bin/data/magic/test.magic",
 385      ...
 386  );
 387  ...
 388  my $schema = $sqlt->schema;
 389
 390  # Test the table it produced.
 391  table_ok( $schema->get_table("Customer"), {
 392      name => "Customer",
 393      fields => [
 394          {
 395              name => "CustomerID",
 396              data_type => "INT",
 397              size => 12,
 398              default_value => undef,
 399              is_nullable => 0,
 400              is_primary_key => 1,
 401          },
 402          {
 403              name => "bar",
 404              data_type => "VARCHAR",
 405              size => 255,
 406              is_nullable => 0,
 407          },
 408      ],
 409      constraints => [
 410          {
 411              type => "PRIMARY KEY",
 412              fields => "CustomerID",
 413          },
 414      ],
 415      indices => [
 416          {
 417              name => "barindex",
 418              fields => ["bar"],
 419          },
 420      ],
 421  });
 422
 423 =head1 DESCSIPTION
 424
 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.
 428
 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 ;-)
 434
 435 For an example of the output run the t/16xml-parser.t test.
 436
 437 =head1 Tests
 438
 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
 443 names.
 444
 445 =head2 table_ok
 446
 447 =head2 field_ok
 448
 449 =head2 constraint_ok
 450
 451 =head2 index_ok
 452
 453 =head2 view_ok
 454
 455 =head2 trigger_ok
 456
 457 =head2 procedure_ok
 458
 459 =head1 EXPORTS
 460
 461 table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok
 462
 463 =head1 TODO
 464
 465 =over 4
 466
 467 =item Test the tests!
 468
 469 =item schema_ok()
 470
 471 Test whole schema.
 472
 473 =item Test skipping
 474
 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.
 478
 479  skip_is_primary_key => "Need to fix primary key parsing.",
 480
 481 =item yaml test specs
 482
 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.
 486
 487 =back
 488
 489 =head1 BUGS
 490
 491 =head1 AUTHOR
 492
 493 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
 494
 495 Thanks to Ken Y. Clark for the original table and field test code taken from
 496 his mysql test.
 497
 498 =head1 SEE ALSO
 499
 500 perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.
 501
 502 =cut