t/60roundtrip.t

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5 use Test::More qw/no_plan/;
   6 use Test::Exception;
   7 use FindBin qw/$Bin/;
   8
   9 use SQL::Translator;
  10
  11 ### Set $ENV{SQLTTEST_RT_DEBUG} = 1 for more output
  12
  13 # What tests to run - parser/producer name, and optional args
  14 my $plan = [
  15   {
  16     engine => 'XML',
  17   },
  18   {
  19     engine => 'SQLite',
  20     producer_args => {},
  21     parser_args => {},
  22   },
  23   {
  24     engine => 'MySQL',
  25     producer_args => {},
  26     parser_args => {},
  27   },
  28   {
  29     engine => 'MySQL',
  30     name => 'MySQL 5.0',
  31     producer_args => { mysql_version => 5 },
  32     parser_args => { mysql_parser_version => 5 },
  33   },
  34   {
  35     engine => 'MySQL',
  36     name => 'MySQL 5.1',
  37     producer_args => { mysql_version => '5.1' },
  38     parser_args => { mysql_parser_version => '5.1' },
  39   },
  40   {
  41     engine => 'PostgreSQL',
  42     producer_args => {},
  43     parser_args => {},
  44   },
  45   {
  46     engine => 'Oracle',
  47     producer_args => {},
  48     parser_args => {},
  49   },
  50   {
  51     engine => 'SQLServer',
  52     producer_args => {},
  53     parser_args => {},
  54   },
  55   {
  56     engine => 'Sybase',
  57     producer_args => {},
  58     parser_args => {},
  59   },
  60   {
  61     engine => 'DB2',
  62     producer_args => {},
  63     parser_args => {},
  64   },
  65
  66 # There is no Access producer
  67 #  {
  68 #    engine => 'Access',
  69 #    producer_args => {},
  70 #    parser_args => {},
  71 #  },
  72 ];
  73
  74
  75 # This data file has the right mix of table/view/procedure/trigger
  76 # definitions, and lists enough quirks to trip up most combos
  77 # I am not sure if augmenting it will break other tests - experiment
  78 my $base_file = "$Bin/data/xml/schema.xml";
  79
  80 my $base_t = SQL::Translator->new;
  81 $base_t->$_ (1) for qw/add_drop_table no_comments/;
  82
  83 my $base_schema = $base_t->translate (
  84   parser => 'XML',
  85   file => $base_file,
  86 ) or die $base_t->error;
  87
  88
  89 for my $args (@$plan) {
  90
  91   $args->{name} ||= $args->{engine};
  92
  93   lives_ok (
  94     sub { check_roundtrip ($args, $base_schema) },
  95     "Round trip for $args->{name} did not throw an exception",
  96   );
  97 }
  98
  99
 100 sub check_roundtrip {
 101   my ($args, $base_schema) = @_;
 102   my $base_t = $base_schema->translator;
 103
 104 # create some output from the submitted schema
 105   my $base_out = $base_t->translate (
 106     data => $base_schema,
 107     producer => $args->{engine},
 108     producer_args => $args->{producer_args},
 109   );
 110
 111   like (
 112     $base_out,
 113     $args->{engine} eq 'XML'  #assume there is at least one table
 114       ? qr/<tables>\s*<table/m
 115       : qr/^\s*CREATE TABLE/m
 116     ,
 117     "Received some meaningful output from the first $args->{name} production",
 118   ) or do {
 119     diag ( _gen_diag ($base_t->error) );
 120     return;
 121   };
 122
 123 # parse the sql back
 124   my $parser_t = SQL::Translator->new;
 125   $parser_t->$_ (1) for qw/add_drop_table no_comments/;
 126   my $mid_schema = $parser_t->translate (
 127     data => $base_out,
 128     parser => $args->{engine},
 129     parser_args => $args->{parser_args},
 130   );
 131
 132   isa_ok ($mid_schema, 'SQL::Translator::Schema', "First $args->{name} parser pass produced a schema:")
 133     or do {
 134       diag (_gen_diag ( $parser_t->error, $base_out ) );
 135       return;
 136     };
 137
 138 # schemas should be comparable at least as far as table/field numbers go
 139   is_deeply (
 140     _get_table_info ($mid_schema->get_tables),
 141     _get_table_info ($base_schema->get_tables),
 142     "Schema tables generally match afer $args->{name} parser trip",
 143   ) or return;
 144
 145 # and produce sql once again
 146
 147 # Producing a schema with a Translator different from the one the schema was generated
 148 # from does not work. This is arguably a bug, 61translator_agnostic.t works with that
 149 #  my $producer_t = SQL::Translator->new;
 150 #  $producer_t->$_ (1) for qw/add_drop_table no_comments/;
 151
 152 #  my $rt_sql = $producer_t->translate (
 153 #    data => $mid_schema,
 154 #    producer => $args->{engine},
 155 #    producer_args => $args->{producer_args},
 156 #  );
 157
 158   my $rt_out = $parser_t->translate (
 159     data => $mid_schema,
 160     producer => $args->{engine},
 161     producer_args => $args->{producer_args},
 162   );
 163
 164   like (
 165     $rt_out,
 166     $args->{engine} eq 'XML'  #assume there is at least one table
 167       ? qr/<tables>\s*<table/m
 168       : qr/^\s*CREATE TABLE/m
 169     ,
 170     "Received some meaningful output from the second $args->{name} production",
 171   ) or do {
 172     diag ( _gen_diag ( $parser_t->error ) );
 173     return;
 174   };
 175
 176 # the two sql strings should be identical
 177   my $msg = "$args->{name} SQL roundtrip successful - SQL statements match";
 178   $ENV{SQLTTEST_RT_DEBUG}
 179     ? is_deeply (
 180       [ split /\n/, $rt_out ],
 181       [ split /\n/, $base_out ],
 182       $msg,
 183     )
 184     : ok ($rt_out eq $base_out, $msg)
 185   ;
 186 }
 187
 188 sub _get_table_info {
 189   my @tables = @_;
 190
 191   my @info;
 192
 193   for my $t (@tables) {
 194     push @info, {
 195       name => $t->name,
 196       fields => [
 197         map { $_->name } ($t->get_fields),
 198       ],
 199     };
 200   }
 201
 202   return \@info;
 203 }
 204
 205 # takes an error string and an optional output block
 206 # returns the string conctenated with a line-numbered block for
 207 # easier reading
 208 sub _gen_diag {
 209   my ($err, $out) = @_;
 210
 211   return 'Unknown error' unless $err;
 212
 213
 214   if ($out and $ENV{SQLTTEST_RT_DEBUG}) {
 215     my @lines;
 216     for (split /\n/, $out) {
 217       push @lines, sprintf ('%03d: %s',
 218         scalar @lines + 1,
 219         $_,
 220       );
 221     }
 222
 223     return "$err\n\n" . join ("\n", @lines);
 224   }
 225
 226   return $err;
 227 }