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