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