lib/Test/SQL/Translator.pm

   1 package Test::SQL::Translator;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Translator.pm,v 1.5 2004-03-05 12:12:33 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.5 $ =~ /(\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
 391
 392 sub schema_ok {
 393     my ($obj,$test,$name) = @_;
 394     my $t_name = t_name($name);
 395     default_attribs($test,"schema");
 396
 397     is( $obj->name, $test->{name}, "${t_name}Schema name is '$test->{name}'" );
 398
 399     is( $obj->database, $test->{database},
 400         "$t_name    database is '$test->{database}'" );
 401
 402     is( $obj->is_valid, $test->{is_valid},
 403     "$t_name    is ".($test->{is_valid} ? '' : 'not ').'valid' );
 404
 405     # Tables
 406     if ( $test->{tables} ) {
 407         is_deeply( [ map {$_->name}   $obj->get_tables ],
 408                    [ map {$_->{name}} @{$test->{tables}} ],
 409                    "${t_name}    table names match" );
 410         foreach ( @{$test->{tables}} ) {
 411             my $t_name = $_->{name} || die "Need a table name to test.";
 412             table_ok( $obj->get_table($t_name), $_, $name );
 413         }
 414     }
 415     else {
 416         is(scalar($obj->get_tables), undef,
 417             "${t_name}    has no tables.");
 418     }
 419
 420     # Procedures, Triggers, Views
 421     _test_kids($obj, $test, $name, {
 422         procedure  => "procedures",
 423         trigger    => "triggers",
 424         view       => "views",
 425     });
 426 }
 427
 428 # maybe_plan($ntests, @modules)
 429 #
 430 # Calls plan $ntests if @modules can all be loaded; otherwise,
 431 # calls skip_all with an explanation of why the tests were skipped.
 432 sub maybe_plan {
 433     my ($ntests, @modules) = @_;
 434     my @errors;
 435
 436     for my $module (@modules) {
 437         eval "use $module;";
 438         if ($@ && $@ =~ /Can't locate (\S+)/) {
 439             my $mod = $1;
 440             $mod =~ s/\.pm$//;
 441             $mod =~ s#/#::#g;
 442             push @errors, $mod;
 443         }
 444     }
 445
 446     if (@errors) {
 447         my $msg = sprintf "Missing dependenc%s: %s",
 448             @errors == 1 ? 'y' : 'ies',
 449             join ", ", @errors;
 450         plan skip_all => $msg;
 451     }
 452     else {
 453         plan tests => $ntests;
 454     }
 455 }
 456
 457 1; # compile please ===========================================================
 458 __END__
 459
 460 =pod
 461
 462 =head1 SYNOPSIS
 463
 464  # t/magic.t
 465
 466  use FindBin '$Bin';
 467  use Test::More;
 468  use Test::SQL::Translator;
 469
 470  # Run parse
 471  my $sqlt = SQL::Translator->new(
 472      parser => "Magic",
 473      filename => "$Bin/data/magic/test.magic",
 474      ...
 475  );
 476  ...
 477  my $schema = $sqlt->schema;
 478
 479  # Test the table it produced.
 480  table_ok( $schema->get_table("Customer"), {
 481      name => "Customer",
 482      fields => [
 483          {
 484              name => "CustomerID",
 485              data_type => "INT",
 486              size => 12,
 487              default_value => undef,
 488              is_nullable => 0,
 489              is_primary_key => 1,
 490          },
 491          {
 492              name => "bar",
 493              data_type => "VARCHAR",
 494              size => 255,
 495              is_nullable => 0,
 496          },
 497      ],
 498      constraints => [
 499          {
 500              type => "PRIMARY KEY",
 501              fields => "CustomerID",
 502          },
 503      ],
 504      indices => [
 505          {
 506              name => "barindex",
 507              fields => ["bar"],
 508          },
 509      ],
 510  });
 511
 512 =head1 DESCSIPTION
 513
 514 Provides a set of Test::More tests for Schema objects. Tesing a parsed
 515 schema is then as easy as writing a perl data structure describing how you
 516 expect the schema to look.
 517
 518 The data structures given to the test subs don't have to include all the
 519 possible values, only the ones you expect to have changed. Any left out will be
 520 tested to make sure they are still at their default value. This is a usefull
 521 check that you your parser hasn't accidentally set schema values you didn't
 522 expect it to. (And makes tests look nice and long ;-)
 523
 524 For an example of the output run the t/16xml-parser.t test.
 525
 526 =head1 Tests
 527
 528 All the tests take a first arg of the schema object to test, followed by a
 529 hash ref describing how you expect that object to look (you only need give the
 530 attributes you expect to have changed from the default).
 531 The 3rd arg is an optional test name to pre-pend to all the generated test
 532 names.
 533
 534 =head2 table_ok
 535
 536 =head2 field_ok
 537
 538 =head2 constraint_ok
 539
 540 =head2 index_ok
 541
 542 =head2 view_ok
 543
 544 =head2 trigger_ok
 545
 546 =head2 procedure_ok
 547
 548 =head1 CONDITIONAL TESTS
 549
 550 The C<maybe_plan> function handles conditionally running an individual
 551 test.  It is here to enable running the test suite even when dependencies
 552 are missing; not having (for example) GraphViz installed should not keep
 553 the test suite from passing.
 554
 555 C<maybe_plan> takes the number of tests to (maybe) run, and a list of
 556 modules on which test execution depends:
 557
 558     maybe_plan(180, 'SQL::Translator::Parser::MySQL');
 559
 560 If one of C<SQL::Translator::Parser::MySQL>'s dependencies does not exist,
 561 then the test will be skipped.
 562
 563 =head1 EXPORTS
 564
 565 table_ok, field_ok, constraint_ok, index_ok, view_ok, trigger_ok, procedure_ok,
 566 maybe_plan
 567
 568 =head1 TODO
 569
 570 =over 4
 571
 572 =item Test the tests!
 573
 574 =item schema_ok()
 575
 576 Test whole schema.
 577
 578 =item Test Count Constants
 579
 580 Constants to give the number of tests each *_ok sub uses. e.g. How many tests
 581 does field_ok run? Can then use these to set up the test plan easily.
 582
 583 =item Test skipping
 584
 585 As the test subs wrap up lots of tests in one call you can't skip idividual
 586 tests only whole sets e.g. a whole table or field.
 587 We could add skip_* items to the test hashes to allow per test skips. e.g.
 588
 589  skip_is_primary_key => "Need to fix primary key parsing.",
 590
 591 =item yaml test specs
 592
 593 Maybe have the test subs also accept yaml for the test hash ref as its a much
 594 nicer for writing big data structures. We can then define tests as in input
 595 schema file and test yaml file to compare it against.
 596
 597 =back
 598
 599 =head1 BUGS
 600
 601 =head1 AUTHOR
 602
 603 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
 604
 605 Thanks to Ken Y. Clark for the original table and field test code taken from
 606 his mysql test.
 607
 608 =head1 SEE ALSO
 609
 610 perl(1), SQL::Translator, SQL::Translator::Schema, Test::More.
 611
 612 =cut