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