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