lib/Test/SQL/Translator.pm

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