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