lib/Test/SQL/Translator.pm

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