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