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 Test::More qw/no_plan/;
  14 use Test::Exception;
  15
  16 use strict;
  17 use Data::Dumper;
  18 our %opt;
  19 BEGIN { map { $opt{$_}=1 if s/^-// } @ARGV; }
  20 use constant DEBUG => (exists $opt{d} ? 1 : 0);
  21 local $SIG{__WARN__} = sub { diag "[warn] ", @_; };
  22
  23 use FindBin qw/$Bin/;
  24
  25 # Usefull test subs for the schema objs
  26 #=============================================================================
  27
  28 our %ATTRIBUTES;
  29 $ATTRIBUTES{field} = [qw/
  30 name
  31 order
  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 ( defined(my $ans = $test->{$attr}) ) {
  50                         if ( $attr =~ m/^is_/ ) {
  51                                 ok $fld->$attr, " $name - $attr true";
  52                         }
  53                         else {
  54                                 is $fld->$attr, $ans, " $name - $attr = '$ans'";
  55                         }
  56                 }
  57                 else {
  58                         ok !$fld->$attr, "$name - $attr not set";
  59                 }
  60         }
  61 }
  62
  63 # TODO test_constraint, test_index
  64
  65 # Testing 1,2,3,4...
  66 #=============================================================================
  67
  68 use SQL::Translator;
  69 use SQL::Translator::Schema::Constants;
  70
  71 # Parse the test XML schema
  72 our $obj;
  73 $obj = SQL::Translator->new(
  74         debug          => DEBUG,
  75         show_warnings  => 1,
  76         add_drop_table => 1,
  77 );
  78 my $testschema = "$Bin/data/xml/schema-basic.xml";
  79 die "Can't find test schema $testschema" unless -e $testschema;
  80 my $sql = $obj->translate(
  81         from     => "SqlfXML",
  82         to       =>"MySQL",
  83         filename => $testschema,
  84 );
  85 print $sql;
  86 #print "Debug:", Dumper($obj) if DEBUG;
  87
  88 # Test the schema objs generted from the XML
  89 #
  90 my $scma = $obj->schema;
  91 my @tblnames = map {$_->name} $scma->get_tables;
  92 is_deeply( \@tblnames, [qw/Basic/], "tables");
  93
  94 # Basic
  95 my $tbl = $scma->get_table("Basic");
  96 is $tbl->order, 1, "Basic->order";
  97 is_deeply( [map {$_->name} $tbl->get_fields], [qw/id title description email/]
  98                                                                                                         , "Table Basic's fields");
  99 test_field($tbl->get_field("id"),{
 100         name => "id",
 101         order => 1,
 102         data_type => "int",
 103         size => 10,
 104         is_primary_key => 1,
 105         is_auto_increment => 1,
 106 });
 107 test_field($tbl->get_field("title"),{
 108         name => "title",
 109         order => 2,
 110         data_type => "varchar",
 111         default_value => "hello",
 112         size => 100,
 113 });
 114 test_field($tbl->get_field("description"),{
 115         name => "description",
 116         order => 3,
 117         data_type => "text",
 118         is_nullable => 1,
 119 });
 120 test_field($tbl->get_field("email"),{
 121         name => "email",
 122         order => 4,
 123         data_type => "varchar",
 124         size => 255,
 125         is_unique => 1,
 126 });
 127
 128 my @indices = $tbl->get_indices;
 129 is scalar(@indices), 1, "Table basic has 1 index";
 130
 131 my @constraints = $tbl->get_constraints;
 132 is scalar(@constraints), 2, "Table basic has 2 constraints";
 133 my $con = shift @constraints;
 134 is $con->table, $tbl, "Constaints table right";
 135 is $con->name, "", "Constaints table right";
 136 is $con->type, PRIMARY_KEY, "Constaint is primary key";
 137 is_deeply [$con->fields], ["id"], "Constaint fields";
 138 $con = shift @constraints;
 139 is $con->table, $tbl, "Constaints table right";
 140 is $con->type, UNIQUE, "Constaint UNIQUE";
 141 is_deeply [$con->fields], ["email"], "Constaint fields";