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.62';
  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->scope, $test->{scope}, "$t_name    scope is '$test->{scope}'" )
 288         if exists $test->{scope};
 289
 290     is( $obj->action, $test->{action}, "$t_name    action is '$test->{action}'" );
 291
 292     is_deeply( { $obj->extra }, $test->{extra}, "$t_name    extra" );
 293 }
 294
 295 sub view_ok {
 296     my ($obj,$test,$name) = @_;
 297     my $t_name = t_name($name);
 298     default_attribs($test,"index");
 299
 300     #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
 301
 302     is( $obj->name, $test->{name}, "${t_name}View '$test->{name}'" );
 303
 304     is( $obj->is_valid, $test->{is_valid},
 305     "$t_name    is ".($test->{is_valid} ? '' : 'not ').'valid' );
 306
 307     is( $obj->sql, $test->{sql}, "$t_name    sql is '$test->{sql}'" );
 308
 309     is_deeply( [$obj->fields], $test->{fields},
 310     "$t_name    fields are '".join(",",@{$test->{fields}})."'" );
 311
 312     is_deeply( { $obj->extra }, $test->{extra}, "$t_name    extra" );
 313 }
 314
 315 sub procedure_ok {
 316     my ($obj,$test,$name) = @_;
 317     my $t_name = t_name($name);
 318     default_attribs($test,"index");
 319
 320     #isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
 321
 322     is( $obj->name, $test->{name}, "${t_name}Procedure '$test->{name}'" );
 323
 324     is( $obj->sql, $test->{sql}, "$t_name    sql is '$test->{sql}'" );
 325
 326     is_deeply( [$obj->parameters], $test->{parameters},
 327     "$t_name    parameters are '".join(",",@{$test->{parameters}})."'" );
 328
 329     is( $obj->comments, $test->{comments},
 330         "$t_name    comments is '$test->{comments}'" );
 331
 332     is( $obj->owner, $test->{owner}, "$t_name    owner is '$test->{owner}'" );
 333
 334     is_deeply( { $obj->extra }, $test->{extra}, "$t_name    extra" );
 335 }
 336
 337 sub table_ok {
 338     my ($obj,$test,$name) = @_;
 339     my $t_name = t_name($name);
 340     default_attribs($test,"table");
 341     my %arg = %$test;
 342
 343     my $tbl_name = $arg{name} || die "Need a table name to test.";
 344     is( $obj->{name}, $arg{name}, "${t_name}Table '$arg{name}'" );
 345
 346     is_deeply( [$obj->options], $test->{options},
 347     "$t_name    options are '".join(",",@{$test->{options}})."'" );
 348
 349     is_deeply( { $obj->extra }, $test->{extra}, "$t_name    extra" );
 350
 351     # Fields
 352     if ( $arg{fields} ) {
 353         my @fldnames = map {$_->{name}} @{$arg{fields}};
 354         is_deeply(
 355             [ map {$_->name}   $obj->get_fields ],
 356             [ @fldnames ],
 357             "${t_name}    field names are ".join(", ",@fldnames)
 358         );
 359         foreach ( @{$arg{fields}} ) {
 360             my $f_name = $_->{name} || die "Need a field name to test.";
 361             next unless my $fld = $obj->get_field($f_name);
 362             field_ok( $fld, $_, $name );
 363         }
 364     }
 365     else {
 366         is(scalar($obj->get_fields), undef,
 367             "${t_name}    has no fields.");
 368     }
 369
 370     # Constraints and Indices
 371     _test_kids($obj, $test, $name, {
 372         constraint => 'constraints',
 373         index      => 'indices',
 374     });
 375 }
 376
 377 sub _test_kids {
 378     my ( $obj, $test, $name, $kids ) = @_;
 379     my $t_name   = t_name($name);
 380     my $obj_name = ref $obj;
 381     ($obj_name) = $obj_name =~ m/^.*::(.*)$/;
 382
 383     while ( my ( $object_type, $plural ) = each %$kids ) {
 384         next unless defined $test->{ $plural };
 385
 386         if ( my @tests = @{ $test->{ $plural } } ) {
 387             my $meth = "get_$plural";
 388             my @objects  = $obj->$meth;
 389             is( scalar(@objects), scalar(@tests),
 390                 "${t_name}$obj_name has " . scalar(@tests) . " $plural"
 391             );
 392
 393             for my $object (@objects) {
 394                 my $ans = { lc($obj_name) => $obj->name, %{ shift @tests } };
 395
 396                 my $meth = "${object_type}_ok";
 397                 {
 398                     no strict 'refs';
 399                     $meth->( $object, $ans, $name );
 400                 }
 401             }
 402         }
 403     }
 404 }
 405
 406 sub schema_ok {
 407     my ($obj,$test,$name) = @_;
 408     my $t_name = t_name($name);
 409     default_attribs($test,"schema");
 410
 411     is( $obj->name, $test->{name}, "${t_name}Schema name is '$test->{name}'" );
 412
 413     is( $obj->database, $test->{database},
 414         "$t_name    database is '$test->{database}'" );
 415
 416     is_deeply( { $obj->extra }, $test->{extra}, "$t_name    extra" );
 417
 418     is( $obj->is_valid, $test->{is_valid},
 419     "$t_name    is ".($test->{is_valid} ? '' : 'not ').'valid' );
 420
 421     # Tables
 422     if ( $test->{tables} ) {
 423         is_deeply( [ map {$_->name}   $obj->get_tables ],
 424                    [ map {$_->{name}} @{$test->{tables}} ],
 425                    "${t_name}    table names match" );
 426         foreach ( @{$test->{tables}} ) {
 427             my $t_name = $_->{name} || die "Need a table name to test.";
 428             table_ok( $obj->get_table($t_name), $_, $name );
 429         }
 430     }
 431     else {
 432         is(scalar($obj->get_tables), undef,
 433             "${t_name}    has no tables.");
 434     }
 435
 436     # Procedures, Triggers, Views
 437     _test_kids($obj, $test, $name, {
 438         procedure  => 'procedures',
 439         trigger    => 'triggers',
 440         view       => 'views',
 441     });
 442 }
 443
 444 # maybe_plan($ntests, @modules)
 445 #
 446 # Calls plan $ntests if @modules can all be loaded; otherwise,
 447 # calls skip_all with an explanation of why the tests were skipped.
 448 sub maybe_plan {
 449     my ($ntests, @modules) = @_;
 450     my @errors;
 451
 452     for my $module (@modules) {
 453         eval "use $module;";
 454         next if !$@;
 455
 456         if ($@ =~ /Can't locate (\S+)/) {
 457             my $mod = $1;
 458             $mod =~ s/\.pm$//;
 459             $mod =~ s#/#::#g;
 460             push @errors, $mod;
 461         }
 462         elsif ($@ =~ /([\w\:]+ version [\d\.]+) required.+?this is only version/) {
 463             push @errors, $1;
 464         }
 465         elsif ($@ =~ /Can't load .+? for module .+?DynaLoader\.pm/i ) {
 466           push @errors, $module;
 467         }
 468         else {
 469             (my $err = $@) =~ s/\n+/\\n/g; # Can't have newlines in the skip message
 470             push @errors, "$module: $err";
 471         }
 472     }
 473
 474     if (@errors) {
 475         my $msg = sprintf "Missing dependenc%s: %s",
 476             @errors == 1 ? 'y' : 'ies',
 477             join ", ", @errors;
 478         plan skip_all => $msg;
 479     }
 480     return unless defined $ntests;
 481
 482     if ($ntests ne 'no_plan') {
 483         plan tests => $ntests;
 484     }
 485     else {
 486         plan 'no_plan';
 487     }
 488 }
 489
 490 1; # compile please ===========================================================
 491 __END__
 492
 493 =pod
 494
 495 =head1 SYNOPSIS
 496
 497  # t/magic.t
 498
 499  use FindBin '$Bin';
 500  use Test::More;
 501  use Test::SQL::Translator;
 502
 503  # Run parse
 504  my $sqlt = SQL::Translator->new(
 505      parser => "Magic",
 506      filename => "$Bin/data/magic/test.magic",
 507      ...
 508  );
 509  ...
 510  my $schema = $sqlt->schema;
 511
 512  # Test the table it produced.
 513  table_ok( $schema->get_table("Customer"), {
 514      name => "Customer",
 515      fields => [
 516          {
 517              name => "CustomerID",
 518              data_type => "INT",
 519              size => 12,
 520              default_value => undef,
 521              is_nullable => 0,
 522              is_primary_key => 1,
 523          },
 524          {
 525              name => "bar",
 526              data_type => "VARCHAR",
 527              size => 255,
 528              is_nullable => 0,
 529          },
 530      ],
 531      constraints => [
 532          {
 533              type => "PRIMARY KEY",
 534              fields => "CustomerID",
 535          },
 536      ],
 537      indices => [
 538          {
 539              name => "barindex",
 540              fields => ["bar"],
 541          },
 542      ],
 543  });
 544
 545 =head1 DESCRIPTION
 546
 547 Provides a set of Test::More tests for Schema objects. Testing a parsed
 548 schema is then as easy as writing a perl data structure describing how you
 549 expect the schema to look. Also provides C<maybe_plan> for conditionally running
 550 tests based on their dependencies.
 551
 552 The data structures given to the test subs don't have to include all the
 553 possible values, only the ones you expect to have changed. Any left out will be
 554 tested to make sure they are still at their default value. This is a useful
 555 check that you your parser hasn't accidentally set schema values you didn't
 556 expect it to.
 557
 558 For an example of the output run the F<t/16xml-parser.t> test.
 559
 560 =head1 Tests
 561
 562 All the tests take a first arg of the schema object to test, followed by a
 563 hash ref describing how you expect that object to look (you only need give the
 564 attributes you expect to have changed from the default).
 565 The 3rd arg is an optional test name to prepend to all the generated test
 566 names.
 567
 568 =head2 table_ok
 569
 570 =head2 field_ok
 571
 572 =head2 constraint_ok
 573
 574 =head2 index_ok
 575
 576 =head2 view_ok
 577
 578 =head2 trigger_ok
 579
 580 =head2 procedure_ok
 581
 582 =head1 CONDITIONAL TESTS
 583
 584 The C<maybe_plan> function handles conditionally running an individual
 585 test.  It is here to enable running the test suite even when dependencies
 586 are missing; not having (for example) GraphViz installed should not keep
 587 the test suite from passing.
 588
 589 C<maybe_plan> takes the number of tests to (maybe) run, and a list of
 590 modules on which test execution depends:
 591
 592     maybe_plan(180, 'SQL::Translator::Parser::MySQL');
 593
 594 If one of C<SQL::Translator::Parser::MySQL>'s dependencies does not exist,
 595 then the test will be skipped.
 596
 597 Instead of a number of tests, you can pass C<undef> if you're using
 598 C<done_testing()>, or C<'no_plan'> if you don't want a plan at all.
 599
 600 =head1 EXPORTS
 601
 602 table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok,
 603 maybe_plan
 604
 605 =head1 TODO
 606
 607 =over 4
 608
 609 =item Test the tests!
 610
 611 =item Test Count Constants
 612
 613 Constants to give the number of tests each C<*_ok> sub uses. e.g. How many tests
 614 does C<field_ok> run? Can then use these to set up the test plan easily.
 615
 616 =item Test skipping
 617
 618 As the test subs wrap up lots of tests in one call you can't skip individual
 619 tests only whole sets e.g. a whole table or field.
 620 We could add C<skip_*> items to the test hashes to allow per test skips. e.g.
 621
 622  skip_is_primary_key => "Need to fix primary key parsing.",
 623
 624 =item yaml test specs
 625
 626 Maybe have the test subs also accept yaml for the test hash ref as it is much
 627 nicer for writing big data structures. We can then define tests as in input
 628 schema file and test yaml file to compare it against.
 629
 630 =back
 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