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         next if !$@;
 470
 471         if ($@ =~ /Can't locate (\S+)/) {
 472             my $mod = $1;
 473             $mod =~ s/\.pm$//;
 474             $mod =~ s#/#::#g;
 475             push @errors, $mod;
 476         }
 477         elsif ($@ =~ /([\w\:]+ version [\d\.]+) required.+?this is only version/) {
 478             push @errors, $1;
 479         }
 480     }
 481
 482     if (@errors) {
 483         my $msg = sprintf "Missing dependenc%s: %s",
 484             @errors == 1 ? 'y' : 'ies',
 485             join ", ", @errors;
 486         plan skip_all => $msg;
 487     }
 488     elsif ($ntests and $ntests ne 'no_plan') {
 489         plan tests => $ntests;
 490     }
 491     else {
 492         plan 'no_plan';
 493     }
 494 }
 495
 496 1; # compile please ===========================================================
 497 __END__
 498
 499 =pod
 500
 501 =head1 SYNOPSIS
 502
 503  # t/magic.t
 504
 505  use FindBin '$Bin';
 506  use Test::More;
 507  use Test::SQL::Translator;
 508
 509  # Run parse
 510  my $sqlt = SQL::Translator->new(
 511      parser => "Magic",
 512      filename => "$Bin/data/magic/test.magic",
 513      ...
 514  );
 515  ...
 516  my $schema = $sqlt->schema;
 517
 518  # Test the table it produced.
 519  table_ok( $schema->get_table("Customer"), {
 520      name => "Customer",
 521      fields => [
 522          {
 523              name => "CustomerID",
 524              data_type => "INT",
 525              size => 12,
 526              default_value => undef,
 527              is_nullable => 0,
 528              is_primary_key => 1,
 529          },
 530          {
 531              name => "bar",
 532              data_type => "VARCHAR",
 533              size => 255,
 534              is_nullable => 0,
 535          },
 536      ],
 537      constraints => [
 538          {
 539              type => "PRIMARY KEY",
 540              fields => "CustomerID",
 541          },
 542      ],
 543      indices => [
 544          {
 545              name => "barindex",
 546              fields => ["bar"],
 547          },
 548      ],
 549  });
 550
 551 =head1 DESCSIPTION
 552
 553 Provides a set of Test::More tests for Schema objects. Testing a parsed
 554 schema is then as easy as writing a perl data structure describing how you
 555 expect the schema to look. Also provides maybe_plan for conditionally running
 556 tests based on their dependencies.
 557
 558 The data structures given to the test subs don't have to include all the
 559 possible values, only the ones you expect to have changed. Any left out will be
 560 tested to make sure they are still at their default value. This is a useful
 561 check that you your parser hasn't accidentally set schema values you didn't
 562 expect it to.
 563
 564 For an example of the output run the t/16xml-parser.t test.
 565
 566 =head1 Tests
 567
 568 All the tests take a first arg of the schema object to test, followed by a
 569 hash ref describing how you expect that object to look (you only need give the
 570 attributes you expect to have changed from the default).
 571 The 3rd arg is an optional test name to pre-pend to all the generated test
 572 names.
 573
 574 =head2 table_ok
 575
 576 =head2 field_ok
 577
 578 =head2 constraint_ok
 579
 580 =head2 index_ok
 581
 582 =head2 view_ok
 583
 584 =head2 trigger_ok
 585
 586 =head2 procedure_ok
 587
 588 =head1 CONDITIONAL TESTS
 589
 590 The C<maybe_plan> function handles conditionally running an individual
 591 test.  It is here to enable running the test suite even when dependencies
 592 are missing; not having (for example) GraphViz installed should not keep
 593 the test suite from passing.
 594
 595 C<maybe_plan> takes the number of tests to (maybe) run, and a list of
 596 modules on which test execution depends:
 597
 598     maybe_plan(180, 'SQL::Translator::Parser::MySQL');
 599
 600 If one of C<SQL::Translator::Parser::MySQL>'s dependencies does not exist,
 601 then the test will be skipped.
 602
 603 =head1 EXPORTS
 604
 605 table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok,
 606 maybe_plan
 607
 608 =head1 TODO
 609
 610 =over 4
 611
 612 =item Test the tests!
 613
 614 =item Test Count Constants
 615
 616 Constants to give the number of tests each *_ok sub uses. e.g. How many tests
 617 does field_ok run? Can then use these to set up the test plan easily.
 618
 619 =item Test skipping
 620
 621 As the test subs wrap up lots of tests in one call you can't skip idividual
 622 tests only whole sets e.g. a whole table or field.
 623 We could add skip_* items to the test hashes to allow per test skips. e.g.
 624
 625  skip_is_primary_key => "Need to fix primary key parsing.",
 626
 627 =item yaml test specs
 628
 629 Maybe have the test subs also accept yaml for the test hash ref as its a much
 630 nicer for writing big data structures. We can then define tests as in input
 631 schema file and test yaml file to compare it against.
 632
 633 =back
 634
 635 =head1 BUGS
 636
 637 =head1 AUTHOR
 638
 639 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
 640 Darren Chamberlain <darren@cpan.org>.
 641
 642 Thanks to Ken Y. Clark for the original table and field test code taken from
 643 his mysql test.
 644
 645 =head1 SEE ALSO
 646
 647 perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.
 648
 649 =cut