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