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 => 'SQLServer',
  48     producer_args => {},
  49     parser_args => {},
  50   },
  51   {
  52     engine => 'Oracle',
  53     producer_args => {},
  54     parser_args => {},
  55     todo => 'Needs volunteers',
  56   },
  57   {
  58     engine => 'Sybase',
  59     producer_args => {},
  60     parser_args => {},
  61     todo => 'Needs volunteers',
  62   },
  63   {
  64     engine => 'DB2',
  65     producer_args => {},
  66     parser_args => {},
  67     todo => 'Needs volunteers',
  68   },
  69
  70 # YAML parsing/producing cycles result in some weird self referencing structure
  71 #  {
  72 #    engine => 'YAML',
  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 # I am not sure if augmenting it will break other tests - experiment
  87 my $base_file = "$Bin/data/xml/schema.xml";
  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 => 'XML',
  94   file => $base_file,
  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   TODO: {
 106     local $TODO = $args->{todo} if $args->{todo};
 107
 108     $args->{name} ||= $args->{engine};
 109
 110     lives_ok (
 111       sub { check_roundtrip ($args, $base_schema) },
 112       "Round trip for $args->{name} did not throw an exception",
 113     );
 114   }
 115 }
 116
 117
 118 sub check_roundtrip {
 119   my ($args, $base_schema) = @_;
 120   my $base_t = $base_schema->translator;
 121
 122 # create some output from the submitted schema
 123   my $base_out = $base_t->translate (
 124     data => $base_schema,
 125     producer => $args->{engine},
 126     producer_args => $args->{producer_args},
 127   );
 128
 129   like (
 130     $base_out,
 131     $string_re->{$args->{engine}} || $string_re->{SQL},
 132     "Received some meaningful output from the first $args->{name} production",
 133   ) or do {
 134     diag ( _gen_diag ($base_t->error) );
 135     return;
 136   };
 137
 138 # parse the sql back
 139   my $parser_t = SQL::Translator->new;
 140   $parser_t->$_ (1) for qw/add_drop_table no_comments/;
 141   my $mid_schema = $parser_t->translate (
 142     data => $base_out,
 143     parser => $args->{engine},
 144     parser_args => $args->{parser_args},
 145   );
 146
 147   isa_ok ($mid_schema, 'SQL::Translator::Schema', "First $args->{name} parser pass produced a schema:")
 148     or do {
 149       diag (_gen_diag ( $parser_t->error, $base_out ) );
 150       return;
 151     };
 152
 153 # schemas should be comparable at least as far as table/field numbers go
 154   is_deeply (
 155     _get_table_info ($mid_schema->get_tables),
 156     _get_table_info ($base_schema->get_tables),
 157     "Schema tables generally match afer $args->{name} parser trip",
 158   ) or return;
 159
 160 # and produce sql once again
 161
 162 # Producing a schema with a Translator different from the one the schema was generated
 163 # from does not work. This is arguably a bug, 61translator_agnostic.t works with that
 164 #  my $producer_t = SQL::Translator->new;
 165 #  $producer_t->$_ (1) for qw/add_drop_table no_comments/;
 166
 167 #  my $rt_sql = $producer_t->translate (
 168 #    data => $mid_schema,
 169 #    producer => $args->{engine},
 170 #    producer_args => $args->{producer_args},
 171 #  );
 172
 173   my $rt_out = $parser_t->translate (
 174     data => $mid_schema,
 175     producer => $args->{engine},
 176     producer_args => $args->{producer_args},
 177   );
 178
 179   like (
 180     $rt_out,
 181     $string_re->{$args->{engine}} || $string_re->{SQL},
 182     "Received some meaningful output from the second $args->{name} production",
 183   ) or do {
 184     diag ( _gen_diag ( $parser_t->error ) );
 185     return;
 186   };
 187
 188 # the two sql strings should be identical
 189   my $msg = "$args->{name} SQL roundtrip successful - SQL statements match";
 190   $ENV{SQLTTEST_RT_DEBUG}     #stringify below because IO::Scalar does not behave nice
 191     ? eq_or_diff ("$rt_out", "$base_out", $msg)
 192     : ok ("$rt_out" eq "$base_out", $msg)
 193   ;
 194 }
 195
 196 sub _get_table_info {
 197   my @tables = @_;
 198
 199   my @info;
 200
 201   for my $t (@tables) {
 202     push @info, {
 203       name => $t->name,
 204       fields => [
 205         map { $_->name } ($t->get_fields),
 206       ],
 207     };
 208   }
 209
 210   return \@info;
 211 }
 212
 213 # takes an error string and an optional output block
 214 # returns the string conctenated with a line-numbered block for
 215 # easier reading
 216 sub _gen_diag {
 217   my ($err, $out) = @_;
 218
 219   return 'Unknown error' unless $err;
 220
 221
 222   if ($out and $ENV{SQLTTEST_RT_DEBUG}) {
 223     my @lines;
 224     for (split /\n/, $out) {
 225       push @lines, sprintf ('%03d: %s',
 226         scalar @lines + 1,
 227         $_,
 228       );
 229     }
 230
 231     return "$err\n\n" . join ("\n", @lines);
 232   }
 233
 234   return $err;
 235 }