The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package URT::FakeDBI;
use strict;
use warnings;

# A DBI-like test class we can force failures on

my %configuration;

sub new {
    my $class = shift;
    return bless {}, $class;
}

sub connect {
    my $class = shift;
    if ($configuration{connect_fail}) {
        $class->set_errstr('connect_fail');
        return undef;
    } else {
        return $class->new();
    }
}

sub configure {
    my $self = shift;
    my($key, $val) = @_;
    $configuration{$key} = $val;
}

sub prepare {
    my $self = shift;
    if ($configuration{prepare_fail}) {
        $self->set_errstr('prepare_fail');
        return undef;
    } else {
        return URT::FakeDBI::sth->new($self);
    }
}

sub do {
    my $self = shift;
    if ($configuration{do_fail}) {
        $self->set_errstr('do_fail');
        return undef;
    } else {
        return 1;
    }
}

sub set_errstr {
    my $self = shift;
    my $key = shift;
    our $errstr = $configuration{$key};
}

sub errstr {
    our $errstr;
    return $errstr;
}

package URT::FakeDBI::sth;

sub new {
    my $class = shift;
    my $dbh = shift;
    return bless \$dbh, $class;
}

sub execute {
    my $self = shift;
    my $dbh = $$self;
    if ($configuration{execute_fail}) {
        $dbh->set_errstr('execute_fail');
        return undef;
    } else {
        return 1;
    }
}

1;