lib/Test/SQL/Translator.pm

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