The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package DBIETester;

use Moo;

use Test::More;
use Try::Tiny;
use JSON;
use FindBin;
use DBI;
use DBIx::ParseException;
use DBIETester::MockErrorDBH;
use Test::Exception;

has driver => (
   is       => 'ro',
   required => 1,
);

has dsn => (
   is       => 'ro',
   required => 1,
);

has username => (
   is       => 'ro',
   required => 0,
);

has password => (
   is       => 'ro',
   required => 0,
);

has test_data => (
   is         => 'lazy',
);

has capabilities => (
   is       => 'lazy',
);

sub _build_capabilities{
   DBIx::ParseException->capabilities({ dbh => $_[0]->dbh })
}

has dbh => (
   is       => 'lazy',
   lazy_build => 1,
);

sub _build_test_data {
   my $self = shift;
   my $json;
   {
      my $filename = "$FindBin::Bin/".$self->driver.".json";
      open( my $fh, '<', $filename)
         or die "could not open $filename: $!";
      my @json = <$fh>;
      $json = join '',@json;
   }
   return from_json($json);
}

sub _build_dbh {
   my $self = shift;
   my $dbh = DBI->connect($self->dsn, $self->username, $self->password);

   $dbh->{HandleError} = DBIx::ParseException->handler({ dbh => $dbh });
   return $dbh;
}

sub create_table {
   my $self = shift;

   $self->dbh->do(delete $self->test_data->{create_table});
}

sub non_unique {
   my $self = shift;
   my $cap = $self->capabilities;
   my $data = $self->test_data->{non_unique};
   return unless $cap->can_unique_constraint;
   subtest 'non-unique' => sub {
      my $e;
      try {
         my $sth = $self->dbh->prepare($data->{stmt});
         $sth->execute(@{$data->{vals}}) for (1..2);
      } catch { $e = $_ };
      isa_ok $e, 'DBIx::Exception::NotUnique';
      like $e->original, qr/${\$data->{err}}/,
         '... and original message got set correctly';
      is $e->column, 'name', '... and column name got set correctly'
         if $cap->can_unique_constraint_column;
      done_testing;
   };
}

sub invalid_table {
   my $self = shift;
   my $cap = $self->capabilities;
   my $data = $self->test_data->{invalid_table};
   return unless $cap->can_no_such_table;
   my $e;
   subtest 'invalid table' => sub {
      try {
         my $sth = $self->dbh->prepare($data->{stmt});
         $sth->execute(@{$data->{vals}});
      } catch { $e = $_ };
      isa_ok $e, 'DBIx::Exception::NoSuchTable';
      like $e->original, qr/${\$data->{err}}/, '... and original message got set correctly';
      is $e->table, 'amigo', '... and table name got set correctly'
         if $cap->can_no_such_table_table;
      done_testing;
   };
}

sub invalid_column {
   my $self = shift;
   my $cap = $self->capabilities;
   my $data = $self->test_data->{invalid_column};
   return unless $cap->can_no_such_column;
   my $e;
   subtest 'invalid column' => sub {
      try {
         my $sth = $self->dbh->prepare($data->{stmt});
         $sth->execute(@{$data->{vals}});
      } catch { $e = $_ };
      isa_ok $e, 'DBIx::Exception::NoSuchColumn';
      like $e->original, qr/${\$data->{err}}/, '... and original message got set correctly';
      is $e->column, 'names', '... and column name got set correctly'
         if $cap->can_no_such_column_column;
      is $e->table, 'amigos', '... and table name got set correctly'
         if $cap->can_no_such_column_table;
      done_testing;
   };
}

sub syntax {
   my $self = shift;
   my $data = $self->test_data->{syntax};
   my $cap = $self->capabilities;

   return unless $cap->can_syntax;
   subtest 'syntax' => sub {
      my $e1;
      my $test = 0;
      try {
         my $sth = $self->dbh->prepare($data->[$test]{stmt});
         $sth->execute($data->[$test]{vals});
      } catch { $e1 = $_   };

      isa_ok $e1, 'DBIx::Exception::Syntax';
      like $e1->original, qr/${\$data->[$test]{err}}/, '... and original message got set correctly';
      is $e1->near, 'INERT', '... and near token got set correctly'
         if $cap->can_syntax_near;

      $test++;
      my $e2;
      try {
         my $sth = $self->dbh->prepare($data->[$test]{stmt});
         $sth->execute($data->[$test]{vals});
      } catch { $e2 = $_ };
      isa_ok $e2, 'DBIx::Exception::Syntax';
      like $e2->original, qr/${\$data->[$test]{err}}/, '... and original message got set correctly';
      is $e2->near, 'INO', '... and near token got set correctly'
         if $cap->can_syntax_near;

      $test++;
      my $e3;
      try {
         my $sth = $self->dbh->prepare($data->[$test]{stmt});
         $sth->execute($data->[$test]{vals});
      } catch { $e3 = $_ };
      isa_ok $e3, 'DBIx::Exception::Syntax';
      like $e3->original, qr/${\$data->[$test]{err}}/, '... and original message got set correctly';
      is $e3->near, 'VALUS', '... and near token got set correctly'
         if $cap->can_syntax_near;

      $test++;
      my $e4;
      try {
         my $sth = $self->dbh->prepare($data->[$test]{stmt});
         $sth->execute($data->[$test]{vals});
      } catch { $e4 = $_ };
      isa_ok $e4, 'DBIx::Exception::Syntax';
      like $e4->original, qr/${\$data->[$test]{err}}/, '... and original message got set correctly';
      is $e4->near, ')', '... and near token got set correctly'
         if $cap->can_syntax_near;

      $test++;
      my $e5;
      try {
         my $sth = $self->dbh->prepare($data->[$test]{stmt});
         $sth->execute($data->[$test]{vals});
      } catch { $e5 = $_ };
      isa_ok $e5, 'DBIx::Exception::Syntax';
      like $e5->original, qr/${\$data->[$test]{err}}/, '... and original message got set correctly';
      is $e5->near, ',', '... and near token got set correctly'
         if $cap->can_syntax_near;
      done_testing;
   };
}

# generic test which just uses the stmt in the test data, runs it against
# the live db and checks that the class and the tokens are set correctly
sub test_generic_live {
   my ($self, $test_name) = @_;
   my $data = $self->test_data->{ $test_name };
   subtest $test_name => sub {
      plan;
      try {
         my $sth = $self->dbh->prepare($data->{stmt});
         $sth->execute(@{$data->{vals}});
      } catch {
         isa_ok $_, $data->{class};
         like $_->original, qr/${\$data->{err}}/, '... and original message got set correctly';
         if (my $tkns = $data->{tokens}) {
            foreach my $col (keys %{$tkns}) {
               is $_->{$col}, $tkns->{$col}, "... and $col token got set correctly";
            }
         }
         done_testing();
      };
   };
}

sub test_generic_mock {
   my ($self, $test_name) = @_;
   my $data = $self->test_data->{ $test_name };
   my $driver = $self->dbh->{Driver}{Name};
   my $parser_class = 'DBIx::ParseException::' . $driver;
   eval "require $parser_class";
   my $mock_dbh_params = $data->{mock_dbh};
   my $mock_dbh = DBIETester::MockErrorDBH->new($mock_dbh_params);

   subtest $test_name => sub {
      plan;
      try {
         # what's the right way to do this?
         $parser_class->can('error_handler')->($mock_dbh->errstr, $mock_dbh);
      } catch {
         isa_ok $_, $data->{class};
         like $_->original, qr/${\$data->{err}}/, '... and original message got set correctly';
         if (my $tkns = $data->{tokens}) {
            foreach my $col (keys %{$tkns}) {
               is $_->{$col}, $tkns->{$col}, "... and $col token got set correctly";
            }
         }
         done_testing();
      }
   }


}

sub run_tests {
   my $self = shift;

   $self->create_table;

   # there are three levels of testing
   # 1) the test has a custom method in this class
   # 2) no custom method, but there is a stmt in the test_data
   #    which can be run against the live db using ->test_generic_live
   # 3) no custom method or stmt, but there is a sample error message
   #    in the test_data which can be thrown at the parser to check
   #    that the correct class and tokens are set (better than nothing basically)
   foreach my $test_name (keys %{$self->test_data}) {
      my $data = $self->test_data->{$test_name};
      if (my $sub = $self->can($test_name)) {
         $sub->($self);
      } else {
         if ($data->{stmt}) {
            $self->test_generic_live($test_name);
         } else {
            $self->test_generic_mock($test_name);
         }
      }
   }
   done_testing;
}

no Moo;
1;