The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w

use strict;

use Test::More tests => 17;

use Test::DatabaseRow;
use Test::Builder::Tester;

$Test::DatabaseRow::dbh = FakeDBI->new();

# cope with the fact that regular expressions changed
# stringification syntax in 5.13.6
my $DEFAULT = $] >= 5.01306 ? '^' : '-xism';

test_out("ok 1 - matches");
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       label => "matches");
test_test("no tests");

test_out("ok 1 - matches");
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       tests => [ fooid => 123,
                  name  => "fred",
                  name  => qr/re/  ],
       description => "matches");
test_test("matching with shortcut");

test_out("ok 1 - matches");
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       tests => { "==" => { fooid => 123    },
                  "eq" => { name  => "fred" },
                  "=~" => { name  => qr/re/ },},
       label => "matches");
test_test("matching without shortcut");

test_out("ok 1 - simple db test");
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       tests => { "==" => { fooid => 123    },
                  "eq" => { name  => "fred" },
                  "=~" => { name  => qr/re/ },},);
test_test("default test name");

test_out("not ok 1 - matches");
test_fail(+4);
test_diag("While checking column 'fooid' on 1st row");
test_diag("         got: 123");
test_diag("    expected: 124");
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       tests => [ fooid => 124,
                  name  => "fred",
                  name  => qr/re/  ],
       label => "matches");
test_test("failing ==");

test_out("not ok 1 - matches");
test_fail(+7);
test_diag("While checking column 'fooid' on 1st row");
test_diag("         got: 123");
test_diag("    expected: 124");
test_diag("The SQL executed was:");
test_diag("  SELECT * FROM dummy WHERE dummy = qtd<dummy>");
test_diag("on database 'bob'");
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       tests => [ fooid => 124,
                  name  => "fred",
                  name  => qr/re/  ],
       label => "matches",
       verbose => 1);
test_test("failing == verbose");

test_out("not ok 1 - matches");
test_fail(+9);
test_diag("While checking column 'fooid' on 1st row");
test_diag("         got: 123");
test_diag("    expected: 124");
test_diag("The SQL executed was:");
test_diag("  SELECT * FROM dummy WHERE dummy = ?");
test_diag("The bound parameters were:");
test_diag("  'dummy'");
test_diag("on database 'bob'");
row_ok(sql => [ "SELECT * FROM dummy WHERE dummy = ?", "dummy"],
       tests => [ fooid => 124,
                  name  => "fred",
                  name  => qr/re/  ],
       label => "matches",
       verbose => 1);
test_test("failing == verbose bind");

test_out("not ok 1 - matches");
test_fail(+4);
test_diag("While checking column 'name' on 1st row");
test_diag(qq{         got: 'fred'});
test_diag(qq{    expected: 'frea'});
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       tests => [ fooid => 123,
                  name  => "frea",
                  name  => qr/re/  ],
       label => "matches");
test_test("failing eq");

test_out("not ok 1 - matches");
test_fail(+7);
test_diag("While checking column 'name' on 1st row");
test_diag(qq{         got: 'fred'});
test_diag(qq{    expected: 'frea'});
test_diag("The SQL executed was:");
test_diag("  SELECT * FROM dummy WHERE dummy = qtd<dummy>");
test_diag("on database 'bob'");
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       tests => [ fooid => 123,
                  name  => "frea",
                  name  => qr/re/  ],
       label => "matches",
       verbose => 1);
test_test("failing eq verbose");

test_out("not ok 1 - matches");
test_fail(+5);
test_diag("While checking column 'name' on 1st row");
test_diag(qq{    'fred'});
test_diag(qq{        =~});
test_diag(qq{    '(?$DEFAULT:rd)'});
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       tests => [ fooid => 123,
                  name  => "fred",
                  name  => qr/rd/  ],
       label => "matches");
test_test("failing =~");

test_out("not ok 1 - matches");
test_fail(+8);
test_diag("While checking column 'name' on 1st row");
test_diag(qq{    'fred'});
test_diag(qq{        =~});
test_diag(qq{    '(?$DEFAULT:rd)'});
test_diag("The SQL executed was:");
test_diag("  SELECT * FROM dummy WHERE dummy = qtd<dummy>");
test_diag("on database 'bob'");
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       tests => [ fooid => 123,
                  name  => "fred",
                  name  => qr/rd/  ],
       label => "matches",
       verbose => 1);
test_test("failing =~ verbose");

test_out("not ok 1 - matches");
test_fail(+5);
test_diag("While checking column 'fooid' on 1st row");
test_diag(qq{    '123'});
test_diag(qq{        <});
test_diag(qq{    '12'});
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       tests => { "<", { fooid => 12 }},
       label => "matches");
test_test("failing <");

test_out("not ok 1 - matches");
test_fail(+5+3);
test_diag("While checking column 'fooid' on 1st row");
test_diag(qq{    '123'});
test_diag(qq{        <});
test_diag(qq{    '12'});
test_diag("The SQL executed was:");
test_diag("  SELECT * FROM dummy WHERE dummy = qtd<dummy>");
test_diag("on database 'bob'");
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       tests => { "<", { fooid => 12 }},
       label => "matches",
       verbose => 1);
test_test("failing < verbose");

test_out("not ok 1 - matches");
test_fail(+2);
test_diag("No matching row returned");
row_ok(dbh   => FakeDBI->new(nomatch => 1),
       sql   => "dummy",
       tests => [ "fooid" => 1 ],
       label => "matches");
test_test("no returned data");

test_out("not ok 1 - matches");
test_fail(+7);
test_diag("No matching row returned");
test_diag("The SQL executed was:");
test_diag("  foo");
test_diag("  bar");
test_diag("  baz");
test_diag("on database 'bob'");
row_ok(dbh   => FakeDBI->new(nomatch => 1),
       sql   => "foo\nbar\nbaz",
       tests => [ "fooid" => 1 ],
       label => "matches",
       verbose => 1);
test_test("no returned data verbose 1");


test_out("not ok 1 - matches");
test_fail(+5);
test_diag("No matching row returned");
test_diag("The SQL executed was:");
test_diag("  SELECT * FROM foo WHERE fooid = qtd<1>");
test_diag("on database 'bob'");
row_ok(dbh   => FakeDBI->new(nomatch => 1),
       table => "foo",
       where => [ "fooid" => 1 ],
       tests => [ "fooid" => 1 ],
       label => "matches",
       verbose => 1);
test_test("no returned data verbose 2");

test_out("ok 1 - right");
row_ok(table => "dummy",
       where => [ dummy => "dummy" ],
       label => "wrong",
       description => "right");
test_test("description trumps label");

# fake database package
package FakeDBI;
sub new { my $class = shift; return bless { @_, Name => "bob" }, $class };
sub quote { return "qtd<$_[1]>" };

sub prepare
{
  my $this = shift;

  # die if we need to
  if ($this->fallover)
    { die "Khaaaaaaaaaaaaan!" }

  return FakeSTH->new($this);
}

sub nomatch  { return $_[0]->{nomatch} }
sub fallover { return $_[0]->{fallover} }

package FakeSTH;
sub new { return bless { parent => $_[1] }, $_[0] };
sub execute { return 1 };
sub fetchrow_hashref
{
  my $this = shift;
  my $parent = $this->{parent};

  # return undef after the first call)
  if ($this->{called})
    { return }
  else
    { $this->{called} = 1 }

  return
    ($parent->nomatch)
     ?  ()
     : { fooid => 123, name => "fred" }
}