lib/Test/SQL/Translator.pm

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