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