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 # YAML parsing/producing cycles result in some weird self referencing structure
  68 #  {
  69 #    engine => 'YAML',
  70 #  },
  71
  72 # There is no Access producer
  73 #  {
  74 #    engine => 'Access',
  75 #    producer_args => {},
  76 #    parser_args => {},
  77 #  },
  78 ];
  79
  80
  81 # This data file has the right mix of table/view/procedure/trigger
  82 # definitions, and lists enough quirks to trip up most combos
  83 # I am not sure if augmenting it will break other tests - experiment
  84 my $base_file = "$Bin/data/xml/schema.xml";
  85
  86 my $base_t = SQL::Translator->new;
  87 $base_t->$_ (1) for qw/add_drop_table no_comments/;
  88
  89 my $base_schema = $base_t->translate (
  90   parser => 'XML',
  91   file => $base_file,
  92 ) or die $base_t->error;
  93
  94 #assume there is at least one table
  95 my $string_re = {
  96   XML => qr/<tables>\s*<table/,
  97   YAML => qr/\A---\n.+tables\:/s,
  98   SQL => qr/^\s*CREATE TABLE/m,
  99 };
 100
 101 for my $args (@$plan) {
 102
 103   $args->{name} ||= $args->{engine};
 104
 105   lives_ok (
 106     sub { check_roundtrip ($args, $base_schema) },
 107     "Round trip for $args->{name} did not throw an exception",
 108   );
 109 }
 110
 111
 112 sub check_roundtrip {
 113   my ($args, $base_schema) = @_;
 114   my $base_t = $base_schema->translator;
 115
 116 # create some output from the submitted schema
 117   my $base_out = $base_t->translate (
 118     data => $base_schema,
 119     producer => $args->{engine},
 120     producer_args => $args->{producer_args},
 121   );
 122
 123   like (
 124     $base_out,
 125     $string_re->{$args->{engine}} || $string_re->{SQL},
 126     "Received some meaningful output from the first $args->{name} production",
 127   ) or do {
 128     diag ( _gen_diag ($base_t->error) );
 129     return;
 130   };
 131
 132 # parse the sql back
 133   my $parser_t = SQL::Translator->new;
 134   $parser_t->$_ (1) for qw/add_drop_table no_comments/;
 135   my $mid_schema = $parser_t->translate (
 136     data => $base_out,
 137     parser => $args->{engine},
 138     parser_args => $args->{parser_args},
 139   );
 140
 141   isa_ok ($mid_schema, 'SQL::Translator::Schema', "First $args->{name} parser pass produced a schema:")
 142     or do {
 143       diag (_gen_diag ( $parser_t->error, $base_out ) );
 144       return;
 145     };
 146
 147 # schemas should be comparable at least as far as table/field numbers go
 148   is_deeply (
 149     _get_table_info ($mid_schema->get_tables),
 150     _get_table_info ($base_schema->get_tables),
 151     "Schema tables generally match afer $args->{name} parser trip",
 152   ) or return;
 153
 154 # and produce sql once again
 155
 156 # Producing a schema with a Translator different from the one the schema was generated
 157 # from does not work. This is arguably a bug, 61translator_agnostic.t works with that
 158 #  my $producer_t = SQL::Translator->new;
 159 #  $producer_t->$_ (1) for qw/add_drop_table no_comments/;
 160
 161 #  my $rt_sql = $producer_t->translate (
 162 #    data => $mid_schema,
 163 #    producer => $args->{engine},
 164 #    producer_args => $args->{producer_args},
 165 #  );
 166
 167   my $rt_out = $parser_t->translate (
 168     data => $mid_schema,
 169     producer => $args->{engine},
 170     producer_args => $args->{producer_args},
 171   );
 172
 173   like (
 174     $rt_out,
 175     $string_re->{$args->{engine}} || $string_re->{SQL},
 176     "Received some meaningful output from the second $args->{name} production",
 177   ) or do {
 178     diag ( _gen_diag ( $parser_t->error ) );
 179     return;
 180   };
 181
 182 # the two sql strings should be identical
 183   my $msg = "$args->{name} SQL roundtrip successful - SQL statements match";
 184   $ENV{SQLTTEST_RT_DEBUG}     #stringify below because IO::Scalar does not behave nice
 185     ? eq_or_diff ("$rt_out", "$base_out", $msg)
 186     : ok ("$rt_out" eq "$base_out", $msg)
 187   ;
 188 }
 189
 190 sub _get_table_info {
 191   my @tables = @_;
 192
 193   my @info;
 194
 195   for my $t (@tables) {
 196     push @info, {
 197       name => $t->name,
 198       fields => [
 199         map { $_->name } ($t->get_fields),
 200       ],
 201     };
 202   }
 203
 204   return \@info;
 205 }
 206
 207 # takes an error string and an optional output block
 208 # returns the string conctenated with a line-numbered block for
 209 # easier reading
 210 sub _gen_diag {
 211   my ($err, $out) = @_;
 212
 213   return 'Unknown error' unless $err;
 214
 215
 216   if ($out and $ENV{SQLTTEST_RT_DEBUG}) {
 217     my @lines;
 218     for (split /\n/, $out) {
 219       push @lines, sprintf ('%03d: %s',
 220         scalar @lines + 1,
 221         $_,
 222       );
 223     }
 224
 225     return "$err\n\n" . join ("\n", @lines);
 226   }
 227
 228   return $err;
 229 }