lib/Test/SQL/Translator.pm

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