X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F60roundtrip.t;h=f0e000dde8e3810c37d0b5b2a3c6a744c272696b;hb=e8ce64809bd4b63c65a17aafba231a8b2357e21e;hp=0a203f0e1f0d4db0ac6827a180b37b33073c81e7;hpb=6c9e9546e58cb9383ec0c9d214107d336404796d;p=dbsrgits%2FSQL-Translator.git

diff --git a/t/60roundtrip.t b/t/60roundtrip.t
index 0a203f0..f0e000d 100644
--- a/t/60roundtrip.t
+++ b/t/60roundtrip.t
@@ -4,16 +4,28 @@ use warnings;
 use strict;
 use Test::More qw/no_plan/;
 use Test::Exception;
-use Test::SQL::Translator qw(maybe_plan);
+use Test::Differences;
 use FindBin qw/$Bin/;
 
 use SQL::Translator;
+use SQL::Translator::Utils qw/ddl_parser_instance/;
+
 
 ### Set $ENV{SQLTTEST_RT_DEBUG} = 1 for more output
 
 # What tests to run - parser/producer name, and optional args
 my $plan = [
   {
+    engine => 'XML',
+    req => 'XML::LibXML 1.69',
+    no_grammar => 1,
+  },
+  {
+    engine => 'YAML',
+    no_grammar => 1,
+  },
+
+  {
     engine => 'SQLite',
     producer_args => {},
     parser_args => {},
@@ -40,76 +52,156 @@ my $plan = [
     producer_args => {},
     parser_args => {},
   },
+  {
+    engine => 'SQLServer',
+    producer_args => {},
+    parser_args => {},
+  },
+
+  {
+    engine => 'Oracle',
+    producer_args => {},
+    parser_args => {},
+    todo_cmp => "auto-increment triggers aren't detected",
+  },
+  {
+    engine => 'Sybase',
+    producer_args => {},
+    parser_args => {},
+    todo => 'Needs volunteers',
+  },
+  {
+    engine => 'DB2',
+    producer_args => {},
+    parser_args => {},
+    todo => 'Needs volunteers',
+  },
+
+# There is no Access producer
+#  {
+#    engine => 'Access',
+#    producer_args => {},
+#    parser_args => {},
+#  },
 ];
 
 
 # This data file has the right mix of table/view/procedure/trigger
 # definitions, and lists enough quirks to trip up most combos
-# I am not sure if augmenting it will break other tests - experiment
-my $base_file = "$Bin/data/xml/schema.xml";
+my $base_file = "$Bin/data/roundtrip_autogen.yaml";
+open (my $base_fh, '<', $base_file) or die "$base_file: $!";
 
 my $base_t = SQL::Translator->new;
-$base_t->$_ (1) for qw/validate add_drop_table no_comments/;
+$base_t->$_ (1) for qw/add_drop_table no_comments quote_identifiers/;
 
 my $base_schema = $base_t->translate (
-  parser => 'XML',
-  file => $base_file,
+  parser => 'YAML',
+  data => do { local $/; <$base_fh>; },
 ) or die $base_t->error;
 
 
+#assume there is at least one table
+my $string_re = {
+  XML => qr/<tables>\s*<table/,
+  YAML => qr/\A---\n.+tables\:/s,
+  SQL => qr/^\s*CREATE TABLE/m,
+};
+
 for my $args (@$plan) {
+  SKIP: {
+    $args->{name} ||= $args->{engine};
+
+    my @req = ref $args->{req} ? @{$args->{req}} : $args->{req}||();
+    my @missing;
+    for (@req) {
+      eval "use $_ ()";
+      push @missing, $_ if ($@);
+    }
+    if (@missing) {
+      skip sprintf ('Need %s for %s roundtrip test',
+        join (', ', @missing),
+        $args->{name},
+      );
+    }
 
-  $args->{name} ||= $args->{engine};
+    use_ok("SQL::Translator::Producer::$args->{engine}");
+    use_ok("SQL::Translator::Parser::$args->{engine}");
 
-  lives_ok (
-    sub { check_roundtrip ($args, $base_schema) },
-    "Round trip for $args->{name} did not throw an exception",
-  );
+    ok(ddl_parser_instance($args->{engine}), 'Got proper parser instance')
+      unless $args->{no_grammar};
+
+    TODO: {
+      local $TODO = $args->{todo} if $args->{todo};
+
+      no warnings 'once';
+      # silence PR::D from spewing on STDERR
+      local $::RD_ERRORS = 0 if $args->{todo};
+      local $::RD_WARN = 0 if $args->{todo};
+      local $::RD_HINT = 0 if $args->{todo};
+
+      lives_ok (
+        sub { check_roundtrip ($args, $base_schema, $args->{todo_cmp}) },
+        "Round trip for $args->{name} did not throw an exception",
+      );
+    }
+  }
 }
 
 
 sub check_roundtrip {
-  my ($args, $base_schema) = @_;
+  my ($args, $base_schema, $todo_cmp) = @_;
   my $base_t = $base_schema->translator;
 
-# create some sql from the submitted schema
-  my $base_sql = $base_t->translate (
+# create some output from the submitted schema
+  my $base_out = $base_t->translate (
     data => $base_schema,
     producer => $args->{engine},
     producer_args => $args->{producer_args},
   );
 
   like (
-    $base_sql,
-    qr/^\s*CREATE TABLE/m,  #assume there is at least one create table statement
+    $base_out,
+    $string_re->{$args->{engine}} || $string_re->{SQL},
     "Received some meaningful output from the first $args->{name} production",
-  ) or diag ( _gen_diag ($base_t->error) );
+  ) or do {
+    diag ( _gen_diag ($base_t->error) );
+    return;
+  };
 
 # parse the sql back
   my $parser_t = SQL::Translator->new;
-  $parser_t->$_ (1) for qw/validate add_drop_table no_comments/;
+  $parser_t->$_ (1) for qw/add_drop_table no_comments quote_identifiers/;
   my $mid_schema = $parser_t->translate (
-    data => $base_sql,
+    data => $base_out,
     parser => $args->{engine},
     parser_args => $args->{parser_args},
   );
 
   isa_ok ($mid_schema, 'SQL::Translator::Schema', "First $args->{name} parser pass produced a schema:")
-    or diag (_gen_diag ( $parser_t->error, $base_sql ) );
+    or do {
+      diag (_gen_diag ( $parser_t->error, $base_out ) );
+      my $i;
+      note join ("\n" . ( '=' x 76) . "\n",
+        'Unparseable DDL:',
+        (join ("\n", map { ++$i . ":\t$_" } split /\n/, $base_out) ),
+        ''
+      );
+      return;
+    };
 
 # schemas should be comparable at least as far as table/field numbers go
   is_deeply (
     _get_table_info ($mid_schema->get_tables),
     _get_table_info ($base_schema->get_tables),
     "Schema tables generally match afer $args->{name} parser trip",
-  );
+  ) or (diag(explain _get_table_info($mid_schema->get_tables)), return);
 
 # and produce sql once again
 
 # Producing a schema with a Translator different from the one the schema was generated
 # from does not work. This is arguably a bug, 61translator_agnostic.t works with that
 #  my $producer_t = SQL::Translator->new;
-#  $producer_t->$_ (1) for qw/validate add_drop_table no_comments/;
+#  $producer_t->$_ (1) for qw/add_drop_table no_comments/;
 
 #  my $rt_sql = $producer_t->translate (
 #    data => $mid_schema,
@@ -117,27 +209,27 @@ sub check_roundtrip {
 #    producer_args => $args->{producer_args},
 #  );
 
-  my $rt_sql = $parser_t->translate (
+  my $rt_out = $parser_t->translate (
     data => $mid_schema,
     producer => $args->{engine},
     producer_args => $args->{producer_args},
   );
 
   like (
-    $rt_sql,
-    qr/^\s*CREATE TABLE/m,  #assume there is at least one create table statement
+    $rt_out,
+    $string_re->{$args->{engine}} || $string_re->{SQL},
     "Received some meaningful output from the second $args->{name} production",
-  ) or diag ( _gen_diag ( $parser_t->error ) );
+  ) or do {
+    diag ( _gen_diag ( $parser_t->error ) );
+    return;
+  };
 
+  local $TODO = $todo_cmp;
 # the two sql strings should be identical
   my $msg = "$args->{name} SQL roundtrip successful - SQL statements match";
   $ENV{SQLTTEST_RT_DEBUG}
-    ? is_deeply (
-      [ split /\n/, $rt_sql ],
-      [ split /\n/, $base_sql ],
-      $msg,
-    )
-    : ok ($rt_sql eq $base_sql, $msg)
+    ? eq_or_diff ($rt_out, $base_out, $msg)
+    : ok ($rt_out eq $base_out, $msg)
   ;
 }
 
@@ -158,25 +250,25 @@ sub _get_table_info {
   return \@info;
 }
 
-# takes an error string and an optional SQL block
+# takes an error string and an optional output block
 # returns the string conctenated with a line-numbered block for
 # easier reading
 sub _gen_diag {
-  my ($err, $sql) = @_;
+  my ($err, $out) = @_;
 
   return 'Unknown error' unless $err;
 
 
-  if ($sql and $ENV{SQLTTEST_RT_DEBUG}) {
-    my @sql_lines;
-    for (split /\n/, $sql) {
-      push @sql_lines, sprintf ('%03d: %s',
-        scalar @sql_lines + 1,
+  if ($out and $ENV{SQLTTEST_RT_DEBUG}) {
+    my @lines;
+    for (split /\n/, $out) {
+      push @lines, sprintf ('%03d: %s',
+        scalar @lines + 1,
         $_,
       );
     }
 
-    return "$err\n\n" . join ("\n", @sql_lines);
+    return "$err\n\n" . join ("\n", @lines);
   }
 
   return $err;