lib/Test/SQL/Translator.pm

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