lib/Test/SQL/Translator.pm

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