t/16xml-parser.t

   1 #!/usr/bin/perl -w
   2 # vim:filetype=perl
   3
   4 # Before `make install' is performed this script should be runnable with
   5 # `make test'. After `make install' it should work as `perl test.pl'
   6
   7 #
   8 # basic.t
   9 # -------
  10 # Tests that;
  11 #
  12
  13 use strict;
  14 use Test::More;
  15 use Test::Exception;
  16
  17 use strict;
  18 use Data::Dumper;
  19 my %opt;
  20 BEGIN { map { $opt{$_}=1 if s/^-// } @ARGV; }
  21 use constant DEBUG => (exists $opt{d} ? 1 : 0);
  22 local $SIG{__WARN__} = sub { diag "[warn] ", @_; };
  23
  24 use FindBin qw/$Bin/;
  25
  26 # Usefull test subs for the schema objs
  27 #=============================================================================
  28
  29 my %ATTRIBUTES;
  30 $ATTRIBUTES{field} = [qw/
  31 name
  32 data_type
  33 default_value
  34 size
  35 is_primary_key
  36 is_unique
  37 is_nullable
  38 is_foreign_key
  39 is_auto_increment
  40 /];
  41
  42 sub test_field {
  43     my ($fld,$test) = @_;
  44     die "test_field needs a least a name!" unless $test->{name};
  45     my $name = $test->{name};
  46     is $fld->name, $name, "$name - Name right";
  47
  48     foreach my $attr ( @{$ATTRIBUTES{field}} ) {
  49         if ( exists $test->{$attr} ) {
  50             my $ans = $test->{$attr};
  51             if ( $attr =~ m/^is_/ ) {
  52                 if ($ans) { ok $fld->$attr,  "$name - $attr true"; }
  53                 else      { ok !$fld->$attr, "$name - $attr false"; }
  54             }
  55             else {
  56                 is $fld->$attr, $ans, "$name - $attr = '"
  57                                      .(defined $ans ? $ans : "NULL" )."'";
  58             }
  59         }
  60         else {
  61             ok !$fld->$attr, "$name - $attr not set";
  62         }
  63     }
  64 }
  65
  66 # TODO test_constraint, test_index
  67
  68 # Testing 1,2,3,4...
  69 #=============================================================================
  70
  71 plan tests => 198;
  72
  73 use SQL::Translator;
  74 use SQL::Translator::Schema::Constants;
  75
  76 foreach (
  77     "$Bin/data/xml/schema-basic.xml",
  78     "$Bin/data/xml/schema-basic-attribs.xml"
  79 ) {
  80     do_file($_);
  81 }
  82
  83 sub do_file {
  84     my $testschema = shift;
  85     # Parse the test XML schema
  86     my $obj;
  87     $obj = SQL::Translator->new(
  88         debug          => DEBUG,
  89         show_warnings  => 1,
  90         add_drop_table => 1,
  91     );
  92     die "Can't find test schema $testschema" unless -e $testschema;
  93     my $sql = $obj->translate(
  94         from     => 'XML-SQLFairy',
  95         to       => 'MySQL',
  96         filename => $testschema,
  97     );
  98     print $sql if DEBUG;
  99     #print "Debug:", Dumper($obj) if DEBUG;
 100
 101     # Test the schema objs generted from the XML
 102     #
 103     my $scma = $obj->schema;
 104     my @tblnames = map {$_->name} $scma->get_tables;
 105     is_deeply( \@tblnames, [qw/Basic/], "tables");
 106
 107     # Basic
 108     my $tbl = $scma->get_table("Basic");
 109     is_deeply( [map {$_->name} $tbl->get_fields], [qw/
 110         id title description email explicitnulldef explicitemptystring emptytagdef
 111     /] , "Table Basic's fields");
 112     test_field($tbl->get_field("id"),{
 113         name => "id",
 114         data_type => "int",
 115         default_value => undef,
 116         is_nullable => 0,
 117         size => 10,
 118         is_primary_key => 1,
 119         is_auto_increment => 1,
 120     });
 121     test_field($tbl->get_field("title"),{
 122         name => "title",
 123         data_type => "varchar",
 124         is_nullable => 0,
 125         default_value => "hello",
 126         size => 100,
 127     });
 128     test_field($tbl->get_field("description"),{
 129         name => "description",
 130         data_type => "text",
 131         is_nullable => 1,
 132         default_value => "",
 133     });
 134     test_field($tbl->get_field("email"),{
 135         name => "email",
 136         data_type => "varchar",
 137         size => 255,
 138         is_unique => 1,
 139         default_value => undef,
 140         is_nullable => 1,
 141     });
 142     test_field($tbl->get_field("explicitnulldef"),{
 143         name => "explicitnulldef",
 144         data_type => "varchar",
 145         default_value => undef,
 146         is_nullable => 1,
 147     });
 148     test_field($tbl->get_field("explicitemptystring"),{
 149         name => "explicitemptystring",
 150         data_type => "varchar",
 151         default_value => "",
 152         is_nullable => 1,
 153     });
 154     test_field($tbl->get_field("emptytagdef"),{
 155         name => "emptytagdef",
 156         data_type => "varchar",
 157         default_value => "",
 158         is_nullable => 1,
 159     });
 160
 161     my @indices = $tbl->get_indices;
 162     is scalar(@indices), 1, "Table basic has 1 index";
 163
 164     my @constraints = $tbl->get_constraints;
 165     is scalar(@constraints), 2, "Table basic has 2 constraints";
 166     my $con = shift @constraints;
 167     is $con->table, $tbl, "Constaints table right";
 168     is $con->name, "", "Constaints table right";
 169     is $con->type, PRIMARY_KEY, "Constaint is primary key";
 170     is_deeply [$con->fields], ["id"], "Constaint fields";
 171     $con = shift @constraints;
 172     is $con->table, $tbl, "Constaints table right";
 173     is $con->type, UNIQUE, "Constaint UNIQUE";
 174     is_deeply [$con->fields], ["email"], "Constaint fields";
 175
 176     #
 177     # View
 178     #
 179     my @views = $scma->get_views;
 180     is( scalar @views, 1, 'Number of views is 1' );
 181     my $v = $views[0];
 182     isa_ok( $v, 'SQL::Translator::Schema::View', 'View' );
 183     is( $v->name, 'email_list', "View's Name is 'email_list'" );
 184     is( $v->sql, "SELECT email FROM Basic WHERE email IS NOT NULL",
 185     "View's sql" );
 186     is( join(",",$v->fields), 'email', "View's Fields" );
 187
 188     #
 189     # Trigger
 190     #
 191     {
 192         my $name                = 'foo_trigger';
 193         my $perform_action_when = 'after';
 194         my $database_event      = 'insert';
 195         my $on_table            = 'foo';
 196         my $action              = 'update modified=timestamp();';
 197         my @triggs = $scma->get_triggers;
 198         is( scalar @triggs, 1, 'Number of triggers is 1' );
 199         my $t = $triggs[0];
 200         isa_ok( $t, 'SQL::Translator::Schema::Trigger', 'Trigger' );
 201         is( $t->name, $name, qq[Name is "$name"] );
 202         is( $t->perform_action_when, $perform_action_when,
 203             qq[Perform action when is "$perform_action_when"] );
 204         is( $t->database_event, $database_event,
 205             qq[Database event is "$database_event"] );
 206         is( $t->on_table, $on_table, qq[Table is "$on_table"] );
 207         is( $t->action, $action, qq[Action is "$action"] );
 208     }
 209
 210     #
 211     # Procedure
 212     #
 213     {
 214         my $name       = 'foo_proc';
 215         my $sql        = 'select foo from bar';
 216         my $parameters = 'foo, bar';
 217         my $owner      = 'Nomar';
 218         my $comments   = 'Go Sox!';
 219         my @procs = $scma->get_procedures;
 220         is( scalar @procs, 1, 'Number of procedures is 1' );
 221         my $p = $procs[0];
 222         isa_ok( $p, 'SQL::Translator::Schema::Procedure', 'Procedure' );
 223         is( $p->name, $name, qq[Name is "$name"] );
 224         is( $p->sql, $sql, qq[SQL is "$sql"] );
 225         is( join(',', $p->parameters), 'foo,bar', qq[Params = 'foo,bar'] );
 226         is( $p->comments, $comments, qq[Comments = "$comments"] );
 227     }
 228
 229 } # /Test of schema